C Modified version of STRT70A for MGE2XX program
C	GEMPACK Software System			    Impact Project
C	-----------------------			    --------------
C
	SUBROUTINE GPCLED( expdat,
     *      datcor, hasexp, wrnexp, 
     *    ERRMES)
C
C   ACRONYM
C   -------
C
C GemPack: Check Licence Expiry Date
C G  P     C     L       E      D
C
C	COPYRIGHT 1996-2000: The Impact Project and KPSOFT
C
C   DESCRIPTION
C   -----------
C
C	This checks the expiry date syntactically and to see
C	 if it has expired or about to expire.
C
C   CURRENT VERSION
C   ---------------
C
C	Version 1.1		January 2000
C
C   HISTORY
C   -------
C
C   Date           Author(s)            Comments
C   --------------------------------------------------------------
C   11/01/2000     Ken Pearson		V 1.1 - 4 fig years 
C   02/05/95       Ken Pearson		Version 1 
C
C   NOTES
C   -----
C

C
C   FINE PRINT
C   ----------
C
C	- All variables and arrays are explicitly declared. None
C	  are implicit.
C
C   SUBROUTINE VARIABLES
C   --------------------
C
C   (1) INPUT VARIABLES (NOT ALTERED):
C
C.R6	EXPDAT - expiry data in form DD-MMM-YY
C	EXPDAT - expiry data in form DD-MMM-YYYY
C
	character*(*) expdat
C
C   (2) OUTPUT VARIABLES (RETURNED):
C
C	DATCOR - if date is syntactically correct
C	HASEXP - if licence has expired
C	WRNEXP - if warn that licence is about to expire
C
	logical datcor, hasexp, wrnexp
C
C   (3) INPUT/OUTPUT VARIABLES:
C
C	ERRMES - Contains fatal error messages if ERRMES(1:1)='E'
C
	CHARACTER*(*) 	ERRMES
C
C   SIGNIFICANT PARAMETERS
C   ----------------------
C
C	SUBNAM - The name of this subroutine
C
	CHARACTER*6 	SUBNAM
	PARAMETER   	(SUBNAM='GPCLED')
C
C   ERROR CHECKING AND HANDLING
C   ---------------------------
C
C	A fatal error (ERRMES(1:1)='E') results if:

C
C   SUBROUTINES AND FUNCTIONS CALLED
C   --------------------------------
C
	EXTERNAL GPDATE
	EXTERNAL GPWERR, GPPGER, PERET, PERETM
C
C	**********************************************************
C
C	End of subroutine documentation 
C
C	**********************************************************
C
C   LOCAL VARIABLES
C   ---------------
C
C.R6	character*9 curdat
	character*11 curdat
	integer curdy, curmn, curyr, expdy, expmn, expyr
	logical isok1, isok2, isok3
C
C   IMPORTANT STATEMENT LABELS
C   --------------------------
C
C	15000	15300	15500	Error return for orderly stop
C
C	**********************************************************
C
C	Subroutine begins
C
C	**********************************************************
C
	hasexp=.FALSE.
	wrnexp=.FALSE.
	datcor=.FALSE.
C
C	Check EXPDAT
C
	call GPCTIP( expdat(1:2), isok1, expdy, errmes)
        if( errmes(1:1).eq.'E') goto 15000
C.R6	call GPCTIP( expdat(8:9), isok3, expyr, errmes)
	call GPCTIP( expdat(8:11), isok3, expyr, errmes)
        if( errmes(1:1).eq.'E') goto 15000
C
	call GPCMN( expdat(4:6), expmn, isok2, errmes)
        if( errmes(1:1).eq.'E') goto 15000
C
	if(expdat(3:3).ne.'-'.or.expdat(7:7).ne.'-'.or.
     *    .not.isok1 .or. .not.isok2 .or. .not.isok3) then
	  datcor=.FALSE.
	  goto 9000
	else
	  datcor=.TRUE.
	end if
C
C.R6	Add the century to EXPYR
C
C.R6	if(expyr.ge.96) then
C.R6	  expyr=expyr+1900
C.R6	else
C.R6	  expyr=expyr+2000
C.R6	end if
C
	call GPDATE( curdat, errmes)
        if( errmes(1:1).eq.'E') goto 15000
C
	if(curdat(1:2).eq.'??') then
C
C	  This is a system on which GEMPACK does not have access to
C	    dates.
C
	  goto 9000
C
	end if
C
	call GPCTIP( curdat(1:2), isok1, curdy, errmes)
        if( errmes(1:1).eq.'E') goto 15000
C.R6	call GPCTIP( curdat(8:9), isok3, curyr, errmes)
	call GPCTIP( curdat(8:11), isok3, curyr, errmes)
        if( errmes(1:1).eq.'E') goto 15000
C
	call GPCMN( curdat(4:6), curmn, isok2, errmes)
        if( errmes(1:1).eq.'E') goto 15000
C
	if(.not.isok1 .or. .not.isok2 .or. .not.isok3) then
	  errmes='E-CURDAT problem'
	  goto 15300
	end if
C	
C
C.R6	Add the century to CURYR
C
C.R6	if(curyr.ge.96) then
C.R6	  curyr=curyr+1900
C.R6	else
C.R6	  curyr=curyr+2000
C.R6	end if
C
	hasexp=.FALSE.
C
	if(expyr.lt.curyr) then
	  hasexp=.TRUE.
	else if(expyr.eq.curyr) then
	  if(expmn.lt.curmn) then
	    hasexp=.TRUE.
	  else if(expmn.eq.curmn) then
	    if(expdy.lt.curdy) then
	      hasexp=.TRUE.
	    end if
	  end if
	end if
C
	if(hasexp) then
	  goto 9000
	end if
C
C	See if must warn
C
	if(expyr.eq.curyr) then
	  if(expmn.eq.curmn) then
	    wrnexp=.TRUE.
	  else if(expmn.eq.curmn+1) then
	    if(expdy.le.curdy) then
	      wrnexp=.TRUE.
	    end if
	  end if
	else if(expyr.eq.curyr+1) then
	  if(expmn.eq.1.and.curmn.eq.12.and.expdy.le.curdy) then
	    wrnexp=.TRUE.
	  end if
	end if
C
C	Normal return
C	-------------
C
9000	continue
	RETURN
C
C	Error RETURN for orderly stop
C	-----------------------------
C
15000	CONTINUE
	CALL PERET (SUBNAM)
	RETURN
C
C   (Program error)
C
15300	CONTINUE
	CALL GPPGER( 0, ERRMES)
	GOTO 15500
C
15500	CONTINUE
	CALL PERETM (SUBNAM, ERRMES)
	RETURN
C
	END
C	GEMPACK Software System			    Impact Project
C	-----------------------			    --------------
C
	LOGICAL FUNCTION GPLCRQ( )
C
C   ACRONYM
C   -------
C
C GemPack: is LiCence ReQuired?
C G  P        L C     R Q
C
C	COPYRIGHT 1996-2001: The Impact Project and KPSOFT
C
C   DESCRIPTION
C   -----------
C

C
C   CURRENT VERSION
C   ---------------
C
C	Version 1.2		June 2001
C
C   HISTORY
C   -------
C
C   Date           Author(s)            Comments
C   --------------------------------------------------------------
C   05/06/01       Ken Pearson		V 1.2 - SAGEM does not require licence
C					 [This is change for Rel 7.0-001]
C   02/04/98       Ken Pearson		V 1.1 - call GPPRN
C   03/05/96       Ken Pearson		Version 1 
C
C   NOTES
C   -----
C

C
C   FINE PRINT
C   ----------
C
C	- All variables and arrays are explicitly declared. None
C	  are implicit.
C
C   SUBROUTINE VARIABLES
C   --------------------
C
C   (1) INPUT VARIABLES (NOT ALTERED):
C

C
C   (2) OUTPUT VARIABLES (RETURNED):
C

C
C   (3) INPUT/OUTPUT VARIABLES:
C
C	ERRMES - Contains fatal error messages if ERRMES(1:1)='E'
C
C	CHARACTER*(*) 	ERRMES
C
C   SIGNIFICANT PARAMETERS
C   ----------------------
C
C	SUBNAM - The name of this subroutine
C
	CHARACTER*6 	SUBNAM
	PARAMETER   	(SUBNAM='GPLCRQ')
C
C   COMMON BLOCK TO CONTROL RUN CHARACTERISTICS
C   -------------------------------------------
C
C
C  GPRCON,GPRCNI stored as common blocks to control various run-time
C	   features such as recovery from invalid input, full/brief prompts,
C          whether running from Stored-input/Command file etc.
C
	character*128 gprcon
	common /gprun/ gprcon
C
C   ERROR CHECKING AND HANDLING
C   ---------------------------
C
C	A fatal error (ERRMES(1:1)='E') results if:

C
C   SUBROUTINES AND FUNCTIONS CALLED
C   --------------------------------
C
C	EXTERNAL GPPGER, PERET, PERETM
C
C	**********************************************************
C
C	End of subroutine documentation 
C
C	**********************************************************
C
C   LOCAL VARIABLES
C   ---------------
C
	character*8 name
C.old	integer i
C
C	**********************************************************
C
C	Subroutine begins
C
C	**********************************************************
C
C
C [01/04/98] Use GPPRN  [No ERRMES in its call]
C.was	do 20 i=1,8
C.was	name(i:i)=gprcon(30+i:30+i)
C.was 20	continue
C
	call GPPRN(name)
C
C [30/05/98] Add SAGEM
C
C.was	if(name.eq.'TABLO'.or.name.eq.'GEMSIM') then
C
C [05/06/01] For Release 7.0-001. SAGEM no longer requires licence
C	[This simplifies "rules of use", eg for RunGTAP, EXE version etc.
C	  Now do not require separate SAGEM.EXEs for Demo, EXE, Source-code]	]
C
C.R70OR	if(name.eq.'TABLO'.or.name.eq.'GEMSIM'
C.R70OR     *			  .or.name.eq.'SAGEM') then
C
	if(name.eq.'TABLO'.or.name.eq.'GEMSIM') then
	  gplcrq=.TRUE.
	else
	  gplcrq=.FALSE.
	end if
C
C	Normal return
C	-------------
C
	RETURN
C
C
C	Error RETURN for orderly stop
C	-----------------------------
C
C15000	CONTINUE
C	CALL PERET (SUBNAM)
C	RETURN
C
C   (Program error)
C
C15300	CONTINUE
C	CALL GPPGER( 0, ERRMES)
C	GOTO 15500
C
C15500	CONTINUE
C	CALL PERETM (SUBNAM, ERRMES)
C	RETURN
C
	END
C       GEMPACK Software System                     Impact Project
C       -----------------------                     --------------
C
        SUBROUTINE GPSTRT (PROGNV,DATES,PRDATE,USEBOP,
C [03/05/96] Pass in PRNAME
C.was     *    GPRC24,ERRMES)
     *    prname,ERRMES)
C
C   ACRONYM
C   -------
C
C       GemPack: STaRT up sequence
C       G  P     ST RT
C
C       COPYRIGHT 1990-96: The Impact Project and KPSOFT
C
C   DESCRIPTION
C   -----------
C
C       This is the startup sequence for the main program
C
C   CURRENT VERSION
C   ---------------
C
C       Version 1.1               May 1996
C
C   HISTORY
C   -------
C
C   Date           Author(s)            Comments
C   --------------------------------------------------------------
C   03/05/96       Ken Pearson          V 1.1 - pass in PRNAME
C   24/03/95       Ken Pearson          Add temporary log file
C   13/04/93       Ken Pearson          GPRCNI added. This may be non-portable
C   11/02/93       Ken Pearson          GPRC24 added
C   23/11/91       Ken Pearson          USEBOP, GPCBOP added
C   10/11/91       Ken Pearson          GPIORB removed
C   29/11/90       Jamie Ebery          Version 1
C
C   NOTES
C   -----
C
C       This subroutine initializes some key strings and displays
C       the title and copyright of the program.
C       It also lets user select the basic program options (e.g. batch)
C
C   FINE PRINT
C   ----------
C
C       - All variables and arrays are explicitly declared. None
C         are implicit.
C
C   SUBROUTINE VARIABLES
C   --------------------
C
C   (1) INPUT VARIABLES (NOT ALTERED):
C
C       PROGNV - The name of the program
        CHARACTER*(*) PROGNV
C       DATES - The dates the copyright was implemented
        CHARACTER*(*) DATES
C       PRDATE - if copyright date is to be printed
C       USEBOP - if the basic options choice is to be offered
C.was       GPRC24 - value of GPRCON(24:24)
C	PRNAME - program name
C
        LOGICAL PRDATE, USEBOP
C.was        CHARACTER*(*) GPRC24
        CHARACTER*(*) prname
C
C   (2) OUTPUT VARIABLES (RETURNED):
C
 
C
C   (3) INPUT/OUTPUT VARIABLES:
C
C       ERRMES - Contains fatal error messages if ERRMES(1:1)='E'
C
        CHARACTER*(*)   ERRMES
C
C   SIGNIFICANT PARAMETERS
C   ----------------------
C
C       SUBNAM - The name of this subroutine
C
        CHARACTER*6     SUBNAM
        PARAMETER       (SUBNAM='GPSTRT')
C
C   ERROR CHECKING AND HANDLING
C   ---------------------------
C
C       A fatal error (ERRMES(1:1)='E') results if:
 
C
C   SUBROUTINES AND FUNCTIONS CALLED
C   --------------------------------
C
        EXTERNAL        ECHPRV, GPUNIT, GPCBOP, GPSREC, GPSSCC, GPWRN
        EXTERNAL        GPSFPR, GPSSTI, GPSCMF, GPSEHA, GPSEFO, GPSECI
        EXTERNAL        GPSRPT, GPDATE, GPDNO, GPYNO
	integer gpdno, gpyno
        EXTERNAL        GPPGER, PERET, PERETM
C       INTRINSIC
C
C       **********************************************************
C
C       End of subroutine documentation
C
C       **********************************************************
C
C   LOCAL VARIABLES
C   ---------------
C
C       COMMON BLOCK FOR GEMPACK RUN CONTROL
C
        CHARACTER*128 GPRCON
        COMMON /GPRUN/ GPRCON
	INTEGER GPRCNI(50)
	COMMON /GPRUNI/ GPRCNI
C
C [29/05/98]  Common blocks for command line
C
	character*256 logfil, stifil, cmdfil
C [GPCMFL is in VBDSCE as well as the routines dealing with comand lines]
	common /GPCMFL/ cmdfil
	common /GPCMLC/ logfil, stifil
	logical sticml, logcml, loncml, cmfcml
	common /GPCMLL/ sticml, logcml, loncml, cmfcml
C
C.R6	character*9 curdat
	character*11 curdat
	integer curyr, curdy, curmn
	logical isok1, isok2, isok3
C
C [21/04/97] Next only used in DOS/Lahey case as arguments (not used)
C        for GPLAHENV.
C
	character tenv
	integer ltenv
C [19/10/99]
	integer i
C
C [21/05/00] Common block for licence name
C  This must be the same in routine GPLIC0 (the only place this is used)
C
	character*256 licnmc
	common /GPLCN2/ licnmc
	logical liccml
C [26/05/00]
	character dupfat, dupocc
C [03/08/00]
	logical dfro
	integer dfroun
	character*1 drofil
C
C   IMPORTANT STATEMENT LABELS
C   --------------------------
C
C       10005 10025 10045       FORMATs for char reads and writes
C       15000   15300   15500   Error return for orderly stop
C
C       **********************************************************
C
C       Subroutine begins
C
C       **********************************************************
C
C       Initialize ERRMES
C
        ERRMES=' '
C
C [19/10/99] Initialise GPRCNI - set all values to -1
	do 12 i=1,50
	gprcni(i)=-1
12	continue
C
C [19/10/99] Initialise GPRCON - set all values to '?'
C
	do 14 i=1,128
	gprcon(i:i)='?'
14	continue
C
C.was        GPRCON(24:24)=GPRC24
C
C [10/09/92] Set abbreviation for program name to a blank initially.
C	[Individual programs can change this if they wish. At present
C	 only TABLO does so.]
C
	call GPSAPN(' ')
C
C [12/05/96]
C
	call GPSVER()
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.old Now not needed even for Absoft 2.4 and Lahey
C.old C.Absoft2.4 and Lahey/DOS
C.old C	   Store current DAY number and YEAR number in GPRCNI(49-50)
C.old C	     These are for use by GPCPU
C.old C.Absoft2.4
C.old Cx	CALL DATE(MM,DD,YY)
C.old C.Lahey/DOS
C.old Cx	CALL DATE(CH8)
C.old C	  CH8 is of form "MM/DD/YY"
C.old Cx	CALL GPCHTI(CH8(1:2),MM,ERRMES)
C.old Cx        IF( ERRMES(1:1).EQ.'E') GOTO 15000
C.old Cx	CALL GPCHTI(CH8(4:5),DD,ERRMES)
C.old Cx        IF( ERRMES(1:1).EQ.'E') GOTO 15000
C.old Cx	CALL GPCHTI(CH8(7:8),YY,ERRMES)
C.old Cx        IF( ERRMES(1:1).EQ.'E') GOTO 15000
C.old C.Absoft2.4 and Lahey/DOS
C.old C	 Store day number (in year) in GPRCNI(49) and year number in GPRCNI(50)
C.old C	  These will be used as base reference by GPCPU.
C.old Cx	GPRCNI(49)=GPDNO(MM,DD,YY)
C.old Cx	GPRCNI(50)=GPYNO(YY)
C.old C.old Now not needed even for Absoft 2.4 and Lahey
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C [03/05/96] Now always store these in GPRCNI(49:50) using GPDATE
C
	call GPDATE( curdat, errmes)
        if( errmes(1:1).eq.'E') goto 15000
C
	call GPCTIP( curdat(1:2), isok1, curdy, errmes)
        if( errmes(1:1).eq.'E') goto 15000
	call GPCMN( curdat(4:6), curmn, isok2, errmes)
        if( errmes(1:1).eq.'E') goto 15000
C.R6	call GPCTIP( curdat(8:9), isok3, curyr, errmes)
	call GPCTIP( curdat(8:11), isok3, curyr, errmes)
        if( errmes(1:1).eq.'E') goto 15000
C
	if(isok1.and.isok2.and.isok3) then
C [11/01/00] Next is still ok since GPDNO just uses CURYR to see
C		if is a leap year
	  GPRCNI(49)=GPDNO(curmn,curdy,curyr)
C.R6	  GPRCNI(50)=GPYNO(curyr)
	  GPRCNI(50)=curyr
	end if
C
	call GPSPRN(prname, errmes)
        if( errmes(1:1).eq.'E') goto 15000
C
C       Initialize ISSTOP to say GPSTOP not called
C
        CALL GPSSTP(.FALSE.)
C
C       Initialize number of warnings at zero
C
        CALL GPWRN('st',0)
C
C       Initialize the unit numbers
C
        CALL GPUNIT('begin',0,ERRMES)
        IF(ERRMES(1:1).EQ.'E') GOTO 15000
C
C       Must initialise LOG output info - initially no LOG file
C
        CALL GPSLOG( .FALSE., 0, ' ', ERRMES)
        IF( ERRMES(1:1).EQ.'E') GOTO 15000
C
C       Tells program that initially recovery from invalid input is allowed
C
        CALL GPSREC( .TRUE., ERRMES)
        IF(ERRMES(1:1).EQ.'E') GOTO 15000
C
C       No control of screen output
C
        CALL GPSSCC( .FALSE., ERRMES)
        IF(ERRMES(1:1).EQ.'E') GOTO 15000
C
C       Tells program that we want full prompts initially
C
        CALL GPSFPR( .TRUE., ERRMES)
        IF(ERRMES(1:1).EQ.'E') GOTO 15000
C
C       Not taking input from a command file (yet)
C
        CALL GPSCMF( .FALSE., ERRMES)
        IF(ERRMES(1:1).EQ.'E') GOTO 15000
C
C       Not taking input from a Stored-input file (yet)
C
        CALL GPSSTI( 'n', 0, ERRMES)
        IF(ERRMES(1:1).EQ.'E') GOTO 15000
C
C       Not storing inputs on a file (yet)
C
        CALL GPSSIF( .FALSE., 0, ERRMES)
        IF(ERRMES(1:1).EQ.'E') GOTO 15000
C
C     Echo all file opening, header activity and Creation Info (to start with)
C
        CALL GPSEHA( 'on', ERRMES)
        IF(ERRMES(1:1).EQ.'E') GOTO 15000
        CALL GPSEFO(.TRUE., ERRMES)
        IF(ERRMES(1:1).EQ.'E') GOTO 15000
        CALL GPSECI(.TRUE., ERRMES)
        IF(ERRMES(1:1).EQ.'E') GOTO 15000
C
C [14/12/95] Set no report file initially
C
	call GPSRPT( .FALSE., 0, errmes)
        if( errmes(1:1).eq.'E') goto 15000
C
C [31/08/99] Set no write error so far
C
	call GPSWER( .FALSE., errmes)
        if( errmes(1:1).eq.'E') goto 15000
C
C [28/04/00] Say that checking of file types (Lahey/Fujitsu)
C	 is on at the start
C
	call GPSTLF( .TRUE., errmes)
        if( errmes(1:1).eq.'E') goto 15000
C
C [29/04/00] Say that converting of files (Lahey/Fujitsu)
C	 is on at the start and are to echo details of such conversions
C
	call GPSCLF( .TRUE., .TRUE., errmes)
        if( errmes(1:1).eq.'E') goto 15000
C
C [21/05/00] Set licence name status to "not known"
C
	call GPSLNS('n', errmes)
        if( errmes(1:1).eq.'E') goto 15000
C
C [03/08/00] Set Deleting file if Run Ok/with error false
C
	dfro=.FALSE.
	dfroun=-100
	drofil=' '
	call GPDFRO('so', dfro, dfroun, drofil, errmes)
        if( errmes(1:1).eq.'E') goto 15000
	call GPDFRO('se', dfro, dfroun, drofil, errmes)
        if( errmes(1:1).eq.'E') goto 15000
C
C [20/09/99] Record the compiler (GPSCMP is in NPORT,NPORT90, NPORT95)
C so that the relevant compiler is set)
C
        call GPSCMP(errmes)
        if( errmes(1:1).eq.'E') goto 15000
C
C [26/05/00] Initialise duplicate header status info
C	 [By deafult, duplicate headers are fatal errors and
C		new files with duplicate headers are deleted - hence
C		'd' below]
C		[If want to change the default to keeping such new files,
C		  change DUPFAT to 'k']
C
	dupfat='d'
	dupocc='n'
	call GPDPHS( 's', dupfat, dupocc, 0, errmes)
        if( errmes(1:1).eq.'E') goto 15000
C
C [27/09/00] Move GPTLOG (which will cause a fatal error if cannot
C		write to current directory) to be after
C		initialising routines (eg GPDPHS) which are not likely to 
C		cause errors.
C [24/03/95] Now always open temporary log file so can capture ALL
C	 output. (Later, if user opens log file, info is transferred
C	  from this temporary file to the permanent one.)
C
	call GPTLOG( prognv, errmes)
        if( errmes(1:1).eq.'E') goto 15000
C
C [21/04/97] Next is DOS/Lahey specific. Tell GPLAHENV that main
C	 program is just starting.
C
	call GPLAHENV('s',tenv,ltenv,errmes)
        if( errmes(1:1).eq.'E') goto 15000
C
C [14/10/99] Move GPPCML to before any screen output so can
C	  know is program is to run silently first.
C
C [29/05/98] Process command line
C
C MGE2XX. Do not call this. Instead set LOGCML etc all false
C.MGE2XX        call GPPCML( prname,
C.MGE2XX     *    logcml, loncml, logfil,
C.MGE2XX     *    sticml, stifil,
C.MGE2XX     *    cmfcml, cmdfil,
C [21/05/00] Add LICCML, LICNMC
C.MGE2XX     *    liccml, licnmc,
C.MGE2XX     *    ERRMES)
C.MGE2XX        IF(ERRMES(1:1).EQ.'E') GOTO 15000
	logcml=.false.
	sticml=.false.
	cmfcml=.false.
	liccml=.false.
C
C [21/05/00] If licence name is specified on command line,
C	  change licence name status
C
	if(liccml) then
	  call GPSLNS('c', errmes)
          IF(ERRMES(1:1).EQ.'E') GOTO 15000
	end if
C
C [29/05/98] Also call GPCBOP if certain things are set on command line
C [24/03/00] This moved earlier to here (before ECHPRV).
C This is so that if is -log/lon/los on Command line,
C    temporary log is converted to permanent log before licence check
C	is made (in ECHPRV). [Then log file catches licence problem message.]
C
        IF(USEBOP.or.sticml.or.logcml.or.loncml) THEN
C
C [29/05/98] Add JSTCML=.NOT.USEBOP to tell if are just processing
C		command line options
C
C.was          CALL GPCBOP( PROGNV, ERRMES)
          CALL GPCBOP( PROGNV, .not.usebop, ERRMES)
          IF(ERRMES(1:1).EQ.'E') GOTO 15000
        END IF
C
C [24/03/95] This next bit moved here (after temporary log file is open)
C       Echo program name and version to the screen
C
C [MGE2XX] Do not call this
C.MGE2XX        CALL ECHPRV(PROGNV,ERRMES)
C.MGE2XX        IF(ERRMES(1:1).EQ.'E') GOTO 15000
C
        IF(PRDATE) THEN
CT10      format(/,1x,'    << COPYRIGHT ',A,
CT     *      ': The Impact Project and KPSOFT >>')
CT        write(*,10) date
          CALL GPTO1(
     *      '\n    << COPYRIGHT %t: The Impact Project and KPSOFT >>',
     *      DATES,0,ERRMES)
          IF(ERRMES(1:1).EQ.'E') GOTO 15000
        END IF
C
C [29/05/98] Process command line
C [14/10/99] This moved slightly earlier
C
C [29/05/98] Also call GPCBOP if certain things are set on command line
C [24/03/00] This moved earlier
C
C       Normal return
C       -------------
C
        RETURN
C
C       Formats for character READs and WRITEs
C       --------------------------------------
C
10005   FORMAT (A)
10025   FORMAT (1X, 10A)
10045   FORMAT (/, 1X, 10A)
C
C       Error RETURN for orderly stop
C       -----------------------------
C
15000   CONTINUE
        CALL PERET (SUBNAM)
        RETURN
C
C   (Program error)
C
15300   CONTINUE
        CALL GPPGER( 0, ERRMES)
        GOTO 15500
C
15500   CONTINUE
        CALL PERETM (SUBNAM, ERRMES)
        RETURN
C
C
        END
C	GEMPACK Software System			    Impact Project
C	-----------------------			    --------------
C
	SUBROUTINE GPVER( vtype,
     *    ERRMES)
C
C   ACRONYM
C   -------
C
C GemPack: get VERsion type
C G  P         VER
C
C	COPYRIGHT 1996: The Impact Project and KPSOFT
C
C   DESCRIPTION
C   -----------
C
C	This gets the version of GEMPACK in use - namely source-code,
C	  executable-image or one requiring no licence.
C
C   CURRENT VERSION
C   ---------------
C
C	Version 1		May 1996
C
C   HISTORY
C   -------
C
C   Date           Author(s)            Comments
C   --------------------------------------------------------------
C   12/05/96       Ken Pearson		Version 1 
C
C   NOTES
C   -----
C

C
C   FINE PRINT
C   ----------
C
C	- All variables and arrays are explicitly declared. None
C	  are implicit.
C
C   SUBROUTINE VARIABLES
C   --------------------
C
C   (1) INPUT VARIABLES (NOT ALTERED):
C

C
C   (2) OUTPUT VARIABLES (RETURNED):
C
C	VTYPE - 's' [source], 'e' [exe] or 'n' [none]
C
	character*(*) vtype
C
C   (3) INPUT/OUTPUT VARIABLES:
C
C	ERRMES - Contains fatal error messages if ERRMES(1:1)='E'
C
	CHARACTER*(*) 	ERRMES
C
C   SIGNIFICANT PARAMETERS
C   ----------------------
C
C	SUBNAM - The name of this subroutine
C
	CHARACTER*6 	SUBNAM
	PARAMETER   	(SUBNAM='GPVER')
C
C   ERROR CHECKING AND HANDLING
C   ---------------------------
C
C	A fatal error (ERRMES(1:1)='E') results if:

C
C   SUBROUTINES AND FUNCTIONS CALLED
C   --------------------------------
C
	EXTERNAL GPPGER, PERET, PERETM
C
C	**********************************************************
C
C	End of subroutine documentation 
C
C	**********************************************************
C
C   LOCAL VARIABLES
C   ---------------
C
C       COMMON BLOCK FOR GEMPACK RUN CONTROL
C
        CHARACTER*128 GPRCON
        COMMON /GPRUN/ GPRCON
C
C   IMPORTANT STATEMENT LABELS
C   --------------------------
C
C	15000	15300	15500	Error return for orderly stop
C
C	**********************************************************
C
C	Subroutine begins
C
C	**********************************************************
C
	vtype=gprcon(26:26)
C
	if(vtype.ne.'s'.and.vtype.ne.'e'.and.vtype.ne.'n') then
	  errmes='E-Unexpected VTYPE'
	  goto 15300
	end if
C
C	Normal return
C	-------------
C
	RETURN
C
C	Error RETURN for orderly stop
C	-----------------------------
C
15000	CONTINUE
	CALL PERET (SUBNAM)
	RETURN
C
C   (Program error)
C
15300	CONTINUE
	CALL GPPGER( 0, ERRMES)
	GOTO 15500
C
15500	CONTINUE
	CALL PERETM (SUBNAM, ERRMES)
	RETURN
C
	END
C	GEMPACK Software System			    Impact Project
C	-----------------------			    --------------
C
	SUBROUTINE GPDCYP( oline, lineno, chlist,
     *    dline, doneok, hasdat, date, lictyp,
     *    ERRMES)
C
C   ACRONYM
C   -------
C
C GemPack: DeCrYPt a line
C G  P     D C YP
C
C	COPYRIGHT 1996-2000: The Impact Project and KPSOFT
C
C   DESCRIPTION
C   -----------
C
 
C
C   CURRENT VERSION
C   ---------------
C
C	Version 1.2		January 2000
C
C   HISTORY
C   -------
C
C   Date           Author(s)            Comments
C   --------------------------------------------------------------
C   11/01/2000     Ken Pearson		V 1.2 - for Release 7.0 - 4 dig years
C   31/03/98       Ken Pearson		V 1.1 - for Release 6.0
C   12/05/96       Ken Pearson		Version 1 - extracted from GPLIC
C
C   NOTES
C   -----
C
 
C
C   FINE PRINT
C   ----------
C
C	- All variables and arrays are explicitly declared. None
C	  are implicit.
C
C   SUBROUTINE VARIABLES
C   --------------------
C
C   (1) INPUT VARIABLES (NOT ALTERED):
C
C	OLINE - original line
C	CHLIST - list of allowed characters
C	LINENO - line number
C
	character*(*) oline, chlist
	integer lineno
C
C   (2) OUTPUT VARIABLES (RETURNED):
C
C	DONEOK - if done ok
C	DLINE - decrypted line
C	HASDAT - if is expiry date here
C	DATE - date (if is one)
C	LICTYP - licence type
C
	logical doneok, hasdat
	character*(*) dline, date, lictyp
C
C   (3) INPUT/OUTPUT VARIABLES:
C
C	ERRMES - Contains fatal error messages if ERRMES(1:1)='E'
C
	CHARACTER*(*) 	ERRMES
C
C   SIGNIFICANT PARAMETERS
C   ----------------------
C
C	SUBNAM - The name of this subroutine
C
	CHARACTER*6 	SUBNAM
	PARAMETER   	(SUBNAM='GPDCYP')
C
C   ERROR CHECKING AND HANDLING
C   ---------------------------
C
C	A fatal error (ERRMES(1:1)='E') results if:
 
C
C   SUBROUTINES AND FUNCTIONS CALLED
C   --------------------------------
C
	EXTERNAL GPPGER, PERET, PERETM
	INTRINSIC INDEX, LEN
C
C	**********************************************************
C
C	End of subroutine documentation
C
C	**********************************************************
C
C   LOCAL VARIABLES
C   ---------------
C
        INTEGER PR1, PR2, PR3
        PARAMETER (PR1 = 27, PR2 = 7, PR3 = -48)
	integer i, oldpos, pos, numchr, ifac
C
C [11/01/00]
	logical isok1
	integer yearno
	character*70 errmx
C
C   IMPORTANT STATEMENT LABELS
C   --------------------------
C
C	9000			If jump to return
C	15000	15300	15500	Error return for orderly stop
C
C	**********************************************************
C
C	Subroutine begins
C
C	**********************************************************
C
	doneok=.FALSE.
	hasdat=.FALSE.
C
	if(LEN(dline).lt.LEN(oline)) then
	  errmes='E-Line length problem'
	  goto 15300
	end if
C
	numchr=LEN(chlist)
C
	if(lineno.eq.0) then
	  ifac=1
	else if(lineno.gt.0) then
	  ifac=lineno
	else
	  errmes='E-Unexpected LINENO'
	  goto 15300
	end if
C
	dline=' '
C
        DO 100 I = 1, LEN(oline)
           POS = INDEX(CHLIST,OLINE(I:I))
           IF (POS .EQ. 0) then
C	         Corrupted
	      GOTO 9000
	   end if
           OLDPOS = MOD((MOD(PR1*(POS-1) + PR3, NUMCHR)) -
C.orig     *              PR2*I*NLIC, NUMCHR)
     *              PR2*I*ifac, NUMCHR)
           IF (OLDPOS .LT. 0) OLDPOS = NUMCHR + OLDPOS
           OLDPOS = OLDPOS + 1
           DLINE(I:I) = CHLIST(OLDPOS:OLDPOS)
 100    CONTINUE
C
	if(lineno.eq.0) then
C
C	   CH12 is 'd' [date] or ' ' [no expiry date]
C	     But here have DLINE=TOPLIN(2:), so positions are one
C	      less than expect
C
	  if(dline(11:11).eq.'d') then
	    hasdat=.TRUE.
C.Rel6	    if(LEN(date).lt.9) then
	    if(LEN(date).lt.11) then
	      errmes='E-DATE problem'
	      goto 15300
	    else
C
C [11/01/00] Rel 7 licences have century in positions 13,14
C
	      if(dline(13:14).eq.'  ') then
C
C		Infer century to be 19 if year >= 90 or to be 20 if year < 90.
C
		errmx=' '
	        call GPCTIP( dline(9:10), isok1, yearno, errmx)
		if(.not.isok1) then
C	             Corrupted
	          GOTO 9000
		else if(yearno.ge.90) then
C		    Put century "19" in before year
		  date=dline(2:8)//'19'//dline(9:10)
		else
C		    Put century "20" in before year
		  date=dline(2:8)//'20'//dline(9:10)
		end if
C
	      else
C
C		Put century in before year
C
		date=dline(2:8)//dline(13:14)//dline(9:10)
C
	      end if
C
	    end if
	  else if(dline(11:11).eq.' ') then
	    hasdat=.FALSE.
	  else
C	       Corrupted
	    goto 9000
	  end if
C
C	   CH13 is 'e' [exe] or 's' [source-code]
C	     But here have DLINE=TOPLIN(2:), so positions are one
C	      less than expect
C
C.Rel5.2	  if(dline(12:12).eq.'s'.or.dline(12:12).eq.'e') then
	  if(dline(12:12).eq.'s'.or.dline(12:12).eq.'e'.or.
C [08/05/00] For a Rel 7.0 licence 'L' menas introductory licence
     *       dline(12:12).eq.'E'.or.dline(12:12).eq.'L') then
	    lictyp=dline(12:12)
	  else
C	       Corrupted
	    goto 9000
	  end if
C
	end if
C
	doneok=.TRUE.
C
C	Normal return
C	-------------
C
9000	continue
	RETURN
C
C	Error RETURN for orderly stop
C	-----------------------------
C
15000	CONTINUE
	CALL PERET (SUBNAM)
	RETURN
C
C   (Program error)
C
15300	CONTINUE
	CALL GPPGER( 0, ERRMES)
	GOTO 15500
C
15500	CONTINUE
	CALL PERETM (SUBNAM, ERRMES)
	RETURN
C
	END
C   GEMPACK Software System                         Impact Project
C   -----------------------                         --------------
C
        SUBROUTINE GPLIC( DDLIC, NLIC, LIC,
     *    ERRMES)
C
C   ACRONYM
C   -------
C
C       GemPack LICence information
C       G  P    LIC
C
C   DESCRIPTION
C   -----------
C
C       This enables GEMPACK licence information to be available
C       to other GEMPACK routines.
C
C   CURRENT VERSION
C   ---------------
C
C       Version 2.3               April 1998
C
C   HISTORY
C   -------
C
C   Date           Author(s)            Comments
C   --------------------------------------------------------------
C   11 June 1987   Ken Pearson          Version 1.
C   19 Jan  1989   George Codsi         Version 2. (Portable)
C   01 Dec  1991   Ken Pearson         V 2.1 use GPUNIT,GPBNFC
C   May  1996      Ken Pearson         V 2.2 for Release 5.2
C   31 March 1998  Ken Pearson         V 2.3 - for Rel 6.0: calls GPLIC0
C
C   NOTES
C   -----
C
C       - All variables used are declared explicitly.
C
C   SUBROUTINE VARIABLES
C   --------------------
C
C   (1) INPUT VARIABLES (NOT ALTERED):
C
C       DDLIC - The dimension of the array for holding the licence
C               information
C
        INTEGER DDLIC
C
C   (2) OUTPUT VARIABLES (RETURNED):
C
C       NLIC  - The number of lines of licence information
C       LIC(DDLIC) - The lines of licence information
C
        INTEGER NLIC
        CHARACTER*(*) LIC(DDLIC)
C
C   (3) INPUT/OUTPUT VARIABLES:
C
C       ERRMES - Contains fatal error messages if ERRMES(1:1)='E'
C
        CHARACTER*(*)   ERRMES
C
C   SIGNIFICANT PARAMETERS
C   ----------------------
C
C       SUBNAM - The name of this subroutine
C
        CHARACTER*6     SUBNAM
        PARAMETER       (SUBNAM='GPLIC')
C
C
C   ERROR CHECKING AND HANDLING
C   ---------------------------
C
C       A fatal error (ERRMES(1:1)='E') results if:
C
C
C   LOCAL VARIABLES
C   ---------------
C
C	For call to GPLIC0
C
C.R6	character*9 expdat
	character*11 expdat
	logical hasexp
	character lictyp

C       **********************************************************
C
C       End of subroutine documentation
C
C       **********************************************************
C
C   IMPORTANT STATEMENT LABELS
C   --------------------------
C
C       15000   15500           Error return for orderly stop
C
C       **********************************************************
C
C       Subroutine begins
C
C       **********************************************************
C
        call GPLIC0( DDLIC, NLIC, LIC,
C SILENT is false here
     *    lictyp, hasexp, expdat, .FALSE.,
C CRNMSP is false, next are dummies
C.usual   CRNMSP, SCRYUN, SCRYNM, ECHRPT,
     *    .FALSE., 0, ' ', .FALSE.,
     *    ERRMES)
        if( errmes(1:1).eq.'E') goto 15000
C
C       Normal return
C       -------------
C
        RETURN
C
C       Error RETURN for orderly stop
C       -----------------------------
C
15000   CONTINUE
        CALL PERET (SUBNAM)
        RETURN
C
C   (Program error)
C
C15300	CONTINUE
C	CALL GPPGER( 0, ERRMES)
C	GOTO 15500
C
C
C15500   CONTINUE
C        CALL PERETM (SUBNAM, ERRMES)
C        RETURN
C
        END
C   GEMPACK Software System                         Impact Project
C   -----------------------                         --------------
C
        SUBROUTINE GPLIC0( DDLIC, NLIC, LIC,
     *    lictyp, hasexp, expdat, silent,
C [03/04/98] CRNMSP tells if CRYNAM is specified.
C  CRNMSP is FALSE when called usually, but TRUE when call by MKGLIC60
     *    crnmsp, SCRYUN, SCRYNM,
     *    echrpt,
     *    ERRMES)
C
C   ACRONYM
C   -------
C
C       GemPack LICence information - version 0
C       G  P    LIC			      0
C
C   DESCRIPTION
C   -----------
C
C       This enables GEMPACK licence information to be available
C       to other GEMPACK routines.
C
C   CURRENT VERSION
C   ---------------
C
C       Version 2.4               January 2000
C
C   HISTORY
C   -------
C
C   Date           Author(s)            Comments
C   --------------------------------------------------------------
C  Was GPLIC
C   11 June 1987   Ken Pearson          Version 1.
C   19 Jan  1989   George Codsi         Version 2. (Portable)
C   01 Dec  1991   Ken Pearson         V 2.1 use GPUNIT,GPBNFC
C   May  1996      Ken Pearson         V 2.2 for Release 5.2
C  Now GPLIC0
C   31 March 1998  Ken Pearson         V 2.3 for Release 6.0
C   11 Jan 2000    Ken Pearson         V 2.4 for Release 7.0
C
C   NOTES
C   -----
C
C       - All variables used are declared explicitly.
C
C   SUBROUTINE VARIABLES
C   --------------------
C
C   (1) INPUT VARIABLES (NOT ALTERED):
C
C       DDLIC - The dimension of the array for holding the licence
C               information
C	SILENT - whether this is to be silent or not for warnings etc
C		[The routine is never silent if get fatal error]
C	CRNMSP - if CRYNAM (licence file name) specified (usually false)
C	SCRYUN,SCRYNM - unit and name if CRNMSP is true
C	ECHRPT - if echo info to report file (if one is open)
C
        INTEGER DDLIC
	logical silent
	logical crnmsp
	integer scryun
	character*(*) scrynm
	logical echrpt
C
C   (2) OUTPUT VARIABLES (RETURNED):
C
C       NLIC  - The number of lines of licence information
C       LIC(DDLIC) - The lines of licence information
C	LICTYP - licence type: ' '=none, 'L'=Large Sims,
C		   'e'=Limited Exe, 'E'=Unlimited Exe,'s'=Source-code
C [08/05/00] For a Rel 7.0 licence, 'I' means Introductory licence. [However
C		'L' is on the actual file for backwards compatibility]
C	HASEXP - if licence has expired
C	EXPDAT - expiry date
C
        INTEGER NLIC
        CHARACTER*(*) LIC(DDLIC)
	character*(*) lictyp
	logical hasexp
	character*(*) expdat
C
C   (3) INPUT/OUTPUT VARIABLES:
C
C       ERRMES - Contains fatal error messages if ERRMES(1:1)='E'
C
        CHARACTER*(*)   ERRMES
C
C   SIGNIFICANT PARAMETERS
C   ----------------------
C
C       SUBNAM - The name of this subroutine
C
        CHARACTER*6     SUBNAM
        PARAMETER       (SUBNAM='GPLIC0')
C
C       LLCRNM - maximum length of licence file name
C
        INTEGER         LLCRNM
        PARAMETER       (LLCRNM=100)
C
C
C   ERROR CHECKING AND HANDLING
C   ---------------------------
C
C       A fatal error (ERRMES(1:1)='E') results if:
C
C       - DDLIC is less than NLIC.
C       - the length of the licence file name exceeds LLCRNM.
C
C
C   LOCAL VARIABLES
C   ---------------
C       File variables
C       --------------
C
        INTEGER CRYUN
        CHARACTER*(LLCRNM) CRYNAM
        INTEGER LCRYNM
        LOGICAL OPENOK
C
C [02/05/96] For licence expiry etc
C
C.was	character*9 expdat, date1, tmpdat
C [11/01/00] For Rel 7, dates have 11 characters
C.R6	character*9 date1, tmpdat
	character*11 date1, tmpdat
C.was	logical datcor, hasexp, wrnexp, doneok, hasdat, tmplog, curlic
	logical datcor, wrnexp, doneok, hasdat, tmplog, curlic
	character*80 tmplin
	integer st, en
C.was	character lictyp, ch1, vtype
	character ch1, vtype
C [02/04/98]
	integer last
	logical isreal, fndrl1, fndrl2
	real relno, relno1, relno2
	character*80 str1, str2
C
C [30/05/98] For writing licence info to report file (if being written)
C
	logical isrpt, lecrpt
	integer rptun
	character*3 ch3
C
C [03/04/98] LICREQ is usually value returned by GPLCRQ()
	logical licreq
C
C.bug fix [08/05/99]
C
C	CRYAS tells if GPUINT has been called to assign CRYUN
C	CRYOP tells if file is open on CRYUN
C
	logical cryas, cryop
C
C.end of bug fix [08/05/99]
C
C [27/02/00]
	character*6 cmpile
	character*80 mess
	integer n1
C
C [10/05/00] Now distinguish between LICTYP character on licence file
C		and its interpreted value. The former is denoted
C		by LCTPFL and the latter by LICTYP.
C		Before the use of Introductory licences for Rel 7.0,
C		LCTPFL and LICTYP were the same. Now the only
C		time they differ is for Rel 7.0 (and later) Introductory
C		licences when LCTPFL='L' (for backwards compatibility)
C		 and LICTYP='I'

	character lctpfl
	character*40 ch40
C
C       Decryption variables
C       --------------------
C
        INTEGER NUMCHR, MXLNLN, NUM
        CHARACTER BOXTYP
        PARAMETER (NUMCHR = 77)
        CHARACTER*(NUMCHR) CHLIST
        PARAMETER (MXLNLN = 60)
        CHARACTER*(MXLNLN) CLINE, LINE
C
        INTEGER I, POS, OLDPOS, acrecl, j, pos1, pos2, pos3
        INTEGER NUMCHK
C.was        PARAMETER (NUMCHK = 3)
        PARAMETER (NUMCHK = 5)
        INTEGER LINCHK(NUMCHK), STCHK(NUMCHK), ENDCHK(NUMCHK)
C
        SAVE LINCHK, STCHK, ENDCHK
C
C       COMMON BLOCK FOR GEMPACK RUN CONTROL
C
C [31/03/98] GPRCON is no longer needed in this routine
C.old        CHARACTER*128 GPRCON
C.old        COMMON /GPRUN/ GPRCON
C
C [21/05/00] Common block for licence name
C  This must be the same in routine GPSTRT (the only place this is used)
C
	character*256 licnmc
	common /GPLCN2/ licnmc
C
C [21/05/00] SAVE statements for licence name
C
	character*256 licnms
	save licnms
C
	character lcnmst
C [05/06/01] Addition to help diagnosis of licence problems
        character*8 prname
C
C   SUBROUTINES AND FUNCTIONS CALLED
C   --------------------------------
C
        EXTERNAL        gpbnfc,gpunit, OPSEQ, PERET, PERETM,clseq
	external gplcrq, gpdcyp, GPTGP, NLFNAM, gplns, gpslns
	logical gplcrq, GPTGP
	integer NLFNAM
C
C       **********************************************************
C
C       End of subroutine documentation
C
C       **********************************************************
C
C   IMPORTANT STATEMENT LABELS
C   --------------------------
C
C       15000   15500           Error return for orderly stop
C
C       **********************************************************
C
C       Subroutine begins
C
C       **********************************************************
C
C.was        DATA LINCHK, STCHK, ENDCHK / 4, 2, 4, 39, 5, 5, 42, 59, 33 /
        DATA LINCHK, STCHK, ENDCHK / 4, 2, 4, 0, 5, 39, 5, 5, 43, 5,
     *    42, 59, 33, 51, 59 /
C
        NLIC = 0
	hasexp=.FALSE.
	expdat=' '
	lictyp=' '
C
C.bug fix [08/05/99]
C
	cryas=.FALSE.
	cryop=.FALSE.
C
C.end of bug fix [08/05/99]
C
	if(echrpt) then
	  call GPRPT( isrpt, rptun, errmes)
          if( errmes(1:1).eq.'E') goto 15000
	  lecrpt=isrpt
	else
	  lecrpt=.FALSE.
	end if
C
C [20/08/96] If no licence required (eg Demo version), return now
C
C
	call GPVER(vtype, errmes)
        if( errmes(1:1).eq.'E') goto 15000
C
	if(lecrpt) then
	  call GPTOG('f',rptun,
     *      'Program version = %t','\x','\x',vtype,' ',' ',
     *	    0,0,0.,0.,errmes)
          if( errmes(1:1).eq.'E') goto 15000
	end if
C
	if(vtype.eq.'n') then
C
C [31/03/98] VTYPE should never be 'n' for TG-programs.
C
	  if(GPTGP()) then
	    errmes='E-Bad VTYPE for TABLO-generated program'
	    goto 15300
	  end if
C
	  goto 9000
	end if
C
C [11/02/93]
C [07/05/93] Change the character in question
C.old	if(gprcon(24:24).eq.'n') goto 2000
C.no longer	if(gprcon(24:24).eq.'X') goto 2000
C
C
C [03/04/98] Different depending on whether CRNMSP is true
C
      if(crnmsp) then
C
C	  [This is just when this is called by MKGLIC60]
C
	crynam=scrynm
	cryun=scryun
	call TBSLL(crynam, lcrynm, errmes)
	if(errmes(1:1).eq.'E') goto 15000
C  Pretend licence is required here when called by MKGLIC60
	licreq=.TRUE.
C
      else
C
C	[The usual case]
C       Get the licence file name and logical unit to be used.
C
C.v2        CALL GPLCNM( LCRYNM, CRYNAM, CRYUN, ERRMES)
C.v2        IF(ERRMES(1:1).EQ.'E') GOTO 15000
C
	call GPUNIT('new', cryun, errmes)
	if(errmes(1:1).eq.'E') goto 15000
C
C.bug fix [08/05/99] Must make sure "end" this unit otherwise
C	 programs (especially TG-programs) may run out of
C	 unit numbers. Set CRYAS now and use this whenever RETURN
C	 ** This was the real bug that caused these changes
C	  to GPLIC0 08/05/99.
C
	cryas=.TRUE.
C
C.end of bug fix [08/05/99]
C
C [21/05/00] Before call GPBNFC to find licence name, see if
C	 name is already known
C	  [Previously the code was as if LCNMST was 'n']
C
	call GPLNS( lcnmst, errmes)
	if(errmes(1:1).eq.'E') goto 15000
C
	if(lcnmst.eq.'c') then
C
C	   Must be "-lic" specifying licence file on command line/
C	   Licence name is in COMMON block GPLCN2 (put there in GPSTRT)
C	    Transfer it to the SAVE place
C
	  licnms=licnmc
C
C	   Record that is it now in the SAVE place
C
	  call GPSLNS('s', errmes)
	  if(errmes(1:1).eq.'E') goto 15000
C
C	  Change LCNMST to reflect this
C
	  lcnmst='s'
C
	end if
C
	if(lcnmst.eq.'s') then
C
C	  Licence name is in SAVE place - ie in LICNMS - either
C	   because this routine has already been called in this run
C	   or because LCNMST was 's' - see above.
C	  Put licence name into CRYNAM, LCRYNM as if GPBNFC has been called
C
	  crynam=licnms
	  lcrynm=NLFNAM( licnms, LEN(licnms), errmes)
	  if(errmes(1:1).eq.'E') goto 15000
C
	else if(lcnmst.eq.'n') then
C
C  [21/05/00]  Must call GPBNFC as before
C  [21/05/00]   With the changes made today, GPBNFC should only
C		be called at most once in each run.
C
	  call GPBNFC( 'licence', crynam, lcrynm, errmes)
	  if(errmes(1:1).eq.'E') goto 15000
C
          IF(LCRYNM.GT.LLCRNM) THEN
            ERRMES='E-Licence file name is too long'
            GOTO 15500
          END IF
C
C [21/05/00] Transfer it to the SAVE place
C
	  licnms=crynam(1:lcrynm)
C
C	   Record that is it now in the SAVE place
C
	  call GPSLNS('s', errmes)
	  if(errmes(1:1).eq.'E') goto 15000
C
	else
	  errmes='E-Unexpected LCNMST: '//lcnmst
	  goto 15300
	end if
C
	if(lecrpt) then
	  call GPTOG('f',rptun,
     *      'Licence file = %t','\x','\x',crynam(1:lcrynm),' ',' ',
     *	    0,0,0.,0.,errmes)
          if( errmes(1:1).eq.'E') goto 15000
	end if
C
C	Here LICREQ is value returned by GPLCRQ()
C
	licreq=gplcrq()
C
	ch3='no'
	if(licreq) ch3='yes'
C
	if(lecrpt) then
	  call GPTOG('f',rptun,
     *      'Licence required = %t','\x','\x',ch3,' ',' ',
     *	    0,0,0.,0.,errmes)
          if( errmes(1:1).eq.'E') goto 15000
	end if

C
C	End "IF(CRNMSP)"
      end if
C
C [27/02/00] If are using F77L3 compiler, check that
C  CRYNAM has no spaces. Also check that NLFNAM will return
C	it full length.
C
	call GPCCMP(cmpile, errmes)
        if( errmes(1:1).eq.'E') goto 15000
C
	if(cmpile.eq.'F77L3') then
C
	  mess=' '
	  if(INDEX(crynam(1:lcrynm),' ').gt.0) then
	    mess='Licence file name has a space in it'
	  else
	    n1=NLFNAM(crynam(1:lcrynm), lcrynm, errmes)
            if( errmes(1:1).eq.'E') goto 15000
	    if(n1.lt.lcrynm) then
	      mess=
     *           'Licence file name has an unexpected character in it'
	    end if
	  end if
C
	  if(mess.ne.' ') then
	    call GPTO1('\n [Looking for licence file ''%t''.]',
     *        crynam(1:lcrynm), 0, errmes)
            IF(ERRMES(1:1).EQ.'E') GOTO 15000
	    call GPTO1(' \%\% %t.\n   [Are using F77L3.]',
     *	       mess, 0, errmes)
            IF(ERRMES(1:1).EQ.'E') GOTO 15000
C
	    errmes='E-Problem with licence file name (F77L3)'
	    goto 15500
	  end if	    
C
C	  End "IF(CMPILE.EQ.'F77L3')"
	end if
C
C       Open Encrypted file
C
C [03/05/96] Call OPSEQ2 with SILENT .TRUE. so nothing is
C             echoed if fail
C.was        CALL OPSEQ( CRYUN, CRYNAM(1:LCRYNM), 'OLD',
        CALL OPSEQ2( CRYUN, CRYNAM(1:LCRYNM), 'OLD',
C [07/08/92] Change call. ACRECL returned is irrelevant
C.was     *    'FORMATTED', 0, acrecl, OPENOK, ERRMES)
     *    'FORMATTED', 0, acrecl, OPENOK, .TRUE., ERRMES)
        IF(ERRMES(1:1).EQ.'E') GOTO 15000
C
C.bug fix [08/05/99] Update CRYOP
C
	cryop=openok
C
C.end of bug fix [08/05/99]
C
	if(lecrpt) then
	  ch3='no'
	  if(openok) ch3='yes'
	  call GPTOG('f',rptun,
     *      'Licence found = %t','\x','\x',ch3,' ',' ',
     *	    0,0,0.,0.,errmes)
          if( errmes(1:1).eq.'E') goto 15000
	end if
C
        IF(.NOT.OPENOK) THEN
C
C [03/04/98] GPLCRQ() replaced by LICREQ
C.was	  if(gplcrq()) then
	  if(licreq) then
            GOTO 200
	  else
C
C-------------------------------------------------------
C [05/06/01] Addition to help diagnosis of licence problems
C
            call GPPRN(prname)
C
            if(prname.eq.'SAGEM'.or.prname.eq.'TGPROG') then
C
C             These programs do not require a licence to run, but
C               the size of models they can handle is limited
C               if no licence found. The next message will appear
C               very early in the LOG file. It says what licence file
C               is being looked for.
C
	      call GPTO1(
     *  '\n (Licence file "%t" not found - model size limited.)\n',
     *          crynam(1:lcrynm), 0, errmes)
              IF(ERRMES(1:1).EQ.'E') GOTO 15000
C
            end if
C
C [05/06/01] End of addition to help diagnosis of licence problems
C-------------------------------------------------------
C
	    nlic=0
	    goto 9000
	  end if
C
        END IF
C
C       Determine boxtype
C
        READ(UNIT=CRYUN,END=300,ERR=210,FMT=10005) CLINE
        BOXTYP = CLINE
C
	if(boxtyp.ne.'1') then
C	   Corrupted
	  goto 210
	end if
C
C       Define boxing characters and valid characters
C
        CHLIST(1:71) =
     *           'abcdefghijklmnopqrstuvwxyz' //
     *           'ABCDEFGHIJKLMNOPQRSTUVWXYZ' //
     *           '1234567890 ,.-()+&*'
C
         CHLIST(72:77) = '?_=!/%'
C
C.was        IF (BOXTYP .EQ. '1'.or.boxtyp.eq.'1d') THEN
C.was           CHLIST(72:77) = '?_=!/%'
C       ELSE IF (BOXTYP .EQ. '2') THEN
C          CHLIST(72:77) = '?_=!/%'
C       ELSE IF (BOXTYP .EQ. '3') THEN
C          CHLIST(72:77) = '?_=!/%'
C       ELSE IF (BOXTYP .EQ. '4') THEN
C          CHLIST(72:72) = CHAR(218)
C          CHLIST(73:73) = CHAR(191)
C          CHLIST(74:74) = CHAR(192)
C          CHLIST(75:75) = CHAR(217)
C          CHLIST(76:76) = CHAR(196)
C          CHLIST(77:77) = CHAR(179)
C       ELSE IF (BOXTYP .EQ. '5') THEN
C          CHLIST(72:77) = '?_=!/%'
C.was        ELSE
C.was           GOTO 210
C.was        ENDIF
C
C [12/05/96] Rel 5.2 licences have info on rest of this line
C
C [31/03/98] At this stage, CURLIC is true for Rel 5.2 or later licences
C
	curlic=.FALSE.
	lictyp='?'
C
	if(cline(2:).eq.' ') then
	  curlic=.FALSE.
	else
	  curlic=.TRUE.
C
C  Decrypt this info
C
	  call GPDCYP( cline(2:), 0, chlist,
C
C [10/05/00] Now LICTYP on file may be diferent from its
C	        interpreted value here. Use LCTPFL to indicate the
C	        value on the file and LICTYP its interpreted value.
C
C.was     *      line(2:), doneok, hasdat, date1, lictyp,
     *      line(2:), doneok, hasdat, date1, lctpfl,
     *      ERRMES)
          if( errmes(1:1).eq.'E') goto 15000
C
	  if(.not.doneok) goto 210
C
	  if(lecrpt) then
C
	    ch3='no'
	    if(hasdat) ch3='yes'
	    call GPTOG('f',rptun,
     *        'Licence expires = %t','\x','\x',ch3,' ',' ',
     *	      0,0,0.,0.,errmes)
            if( errmes(1:1).eq.'E') goto 15000
C
	    if(hasdat) then
	      call GPTOG('f',rptun,
     *          'Licence expiry data = %t','\x','\x',date1,' ',' ',
     *	        0,0,0.,0.,errmes)
              if( errmes(1:1).eq.'E') goto 15000
	    end if
C
	    call GPTOG('f',rptun,
C [10/05/00] Now put LCTPFL to Report file (for backwards compatibility
C		for Windows programs)
C.was     *        'Licence type = %t','\x','\x',lictyp,' ',' ',
     *        'Licence type = %t','\x','\x',lctpfl,' ',' ',
     *	      0,0,0.,0.,errmes)
            if( errmes(1:1).eq.'E') goto 15000
C
	  end if
C
	end if
C
C       Decrypt and read licence into buffer
C
 20     CONTINUE
        READ(UNIT=CRYUN,END=300,ERR=210,FMT=10005) CLINE
        NLIC = NLIC + 1
        IF(NLIC.GT.DDLIC) THEN
CT           WRITE(*,10035)' There is more licence information than'
CT           WRITE(*,10015)'  the calling subroutine can process.'
CT           WRITE(*,*)
CT     *     '  (The number of lines of licence information is: ',
CT     *     NLIC,').'
           call GPTO1('\n There is more licence information than%s',
     *       '  the calling subroutine can process.',0,errmes)
	   if(errmes(1:1).eq.'E') goto 15000
           call GPTO1(
     *       '  (The number of lines of licence information is %i.)',
     *       ' ',nlic,errmes)
	   if(errmes(1:1).eq.'E') goto 15000
           ERRMES='E-Too much licence information'
C.Rel5.2           GOTO 15500
           GOTO 15300
        END IF
C
C [12/05/96] Use GPDCYP
C
	call GPDCYP( cline, nlic, chlist,
     *    lic(nlic), doneok, tmplog, tmpdat, ch1,
     *    ERRMES)
        if( errmes(1:1).eq.'E') goto 15000
C
	if(.not.doneok) goto 210
C
C [12/05/96] Original code omitted
C
        GOTO 20
300     CONTINUE
C
C [11/01/00] If is Rel 7.0 or later and has expiry date,
C  last line needs to be modified to put century in the right place.
C [This last line is actually line number NLIC-1.]
C
	if(hasdat) then	
	  cline=lic(nlic-1)
	  pos1=INDEX(cline,'(Your GEMPACK licence')
	  if(pos1.gt.1) then
	    if(cline(pos1-1:pos1-1).ne.' ') then
C
C		This must be Rel 7.0 or later.
C    The line is:
C      "x(Your GEMPACK licence expires on dd-mmm-yy.)z"
C      where "xz" is the century.
C	But LINE has "!" in pos 4 and end.
C
	      pos2=INDEX(cline,'.)')
C		Corrupted if POS2=0
	      if(pos2.eq.0) goto 210
C
C		Century comes from positions POS1-1 and POS2+2 in CLINE
C		Adjust LIC(NLIC-1) accordingly
C		[Start and end char of LIC(NLIC-1) are "!"]
C
	      line='   '//cline(4:4)
	      line(pos1-1:)=cline(pos1:pos2-3)//cline(pos1-1:pos1-1)//
     *		  cline(pos2+2:pos2+2)//cline(pos2-2:pos2+1)
	      pos3=LEN(cline)
	      line(pos3:pos3)=cline(pos3:pos3)
	      lic(nlic-1)=line
C
	    end if
	  end if
	end if
C
C
C [05/11/98] Echo licence lines to Report file (if is one)
C
	if (lecrpt) then
C
	    call GPTOG('f',rptun,
     *        'Licence lines = %i','\x','\x',' ',' ',' ',
     *	      nlic,0,0.,0.,errmes)
            if( errmes(1:1).eq.'E') goto 15000
C
	    do 302 i=1,nlic
	    call GPTOG('f',rptun,
     *        'Licence line %i = %t','\x','\x',lic(i),' ',' ',
     *	      i,0,0.,0.,errmes)
            if( errmes(1:1).eq.'E') goto 15000
302	    continue
C
C	    Identify bottom lines (giving licencee details)
C	     [This comes after line with release no]
C
C Find the release number line LINCHK(5) or LINCHK(5)+1 (rel 6 or later)
C
	    call FDRLNO( lic(linchk(5)), fndrl1, relno1, errmes)
            if( errmes(1:1).eq.'E') goto 15000
	    call FDRLNO( lic(linchk(5)+1), fndrl2, relno2, errmes)
            if( errmes(1:1).eq.'E') goto 15000
C
	    if(fndrl1) then
	      if(fndrl2) then
		pos=linchk(5)+2
	      else
		pos=linchk(5)+1
	      end if
C
	      call GPTOG('f',rptun,
     *          'Licencee lines = %i','\x','\x',' ',' ',' ',
     *	        nlic-pos,0,0.,0.,errmes)
              if( errmes(1:1).eq.'E') goto 15000
C
	      do 308 i=pos,nlic-1
C
		cline=lic(i)
C		  Just the part in between ! marks
		st=stchk(5)+1
		en=endchk(5)-1
		line=cline(st:en)
C
C		Strip off leading blanks
C
		do 304 j=1,LEN(line)
		if(line(j:j).ne.' ') then
		  pos1=j
		  goto 306
		end if
304		continue
C
C		Here line is all blank
C
		pos1=1
C
306		continue
C
	    	call GPTOG('f',rptun,
     *            'Licencee line %i = %t','\x','\x',line(pos1:),' ',' ',
     *	          i-pos+1,0,0.,0.,errmes)
            	if( errmes(1:1).eq.'E') goto 15000
C
308	      continue
C
	    end if
C
	end if
C
C End of insertion [05/11/98] to echo licence lines to Report file
C
C       Perform decryption checks
C
        READ(LIC(LINCHK(1))(STCHK(1):ENDCHK(1)),FMT=10110,ERR=210) NUM
        IF (LIC(LINCHK(2))(STCHK(2):ENDCHK(2)) .NE.
     * '            GEMPACK Software System Licence            ')
     *              GOTO 210
        IF (LIC(LINCHK(3))(STCHK(3):ENDCHK(3)) .NE.
     *                  '                 Licence No. ') GOTO 210
C
C [05/11/98] Echo licence no to Report file (if is one)
C
	if (lecrpt) then
C
	    cline=lic(linchk(3))
	    i=endchk(3)+1
	    line=cline(i:i+10)
	    call GPTOG('f',rptun,
     *        'Licence no. = %t','\x','\x',line,' ',' ',
     *	      0,0,0.,0.,errmes)
            if( errmes(1:1).eq.'E') goto 15000
C
	end if
C
C [06/05/96] Test specific to Release 5.2
C [31/03/98] Test specific to Release 6.0
C
C [02/04/98] Try to make Rel 6.0 programs run with licences for
C	subsequent releases (6.1,7.0,etc)
C
C
C [03/04/98] Find the release number on this next line
C
	call FDRLNO( lic(linchk(5)), fndrl1, relno1, errmes)
        if( errmes(1:1).eq.'E') goto 15000
C
	if(.not.fndrl1) then
	  if(curlic) then
C		Corrupted
	      goto 210
	  else
C	     Licence for Release 5.1 or earlier
	    goto 201
	  end if
	end if
C
	if(.not.curlic) then
C	   I doubt that can get to here - just say old licence
	  goto 201
	end if
C
C
C See if next line also has a release number on it
C [Initial Rel 6.0 licence files have 5.2 on line number LINCHK(5) and
C    Rel 6.0 on the next line - this is so Rel 5.2 software will run
C   with Rel 6.0 licences]
C
	call FDRLNO( lic(linchk(5)+1), fndrl2, relno2, errmes)
        if( errmes(1:1).eq.'E') goto 15000
C
	if(.not.fndrl2) then
C
C	  Release number is RELNO1
C
	  relno=relno1
C
	  if(relno.ge.5.195.and.relno.le.5.205) then
C		Rel 5.2 licence - old
C
	      if(lecrpt) then
	        call GPTOG('f',rptun,
     *            'Licence release = 5.2','\x','\x',' ',' ',' ',
     *	          0,0,0.,0.,errmes)
                if( errmes(1:1).eq.'E') goto 15000
	      end if
C
C.bug fix [13/10/98] Add Licence expiry date to RPT file (if is one) for
C		Rel 5.2 licences
C [Similary code comes later for CURLIC case]
C
C [02/05/96] Check expiry date
C
              if(hasdat) then
C
C	  Last line has expiry date.
C
C	   Expiry date is on second last line between characters
C		STCHK(4) and ENDCHK(4)
C
	  	tmplin=lic(nlic-1)
	  	st=stchk(4)
	  	en=endchk(4)
	  	expdat=tmplin(st:en)
C
C	    Compare EXPDAT with DATE1 from first line of file
C
	  	if(expdat.ne.date1) then
C
C	    The two expiry dates do not agree
C
	    	  goto 210
C
	  	end if
C
C	  Check expiry date is ok. This also checks that EXPDAT is as expected
C
	  	call GPCLED( expdat,
     *      	  datcor, hasexp, wrnexp, errmes)
          	if( errmes(1:1).eq.'E') goto 15000
C
C	  DATCOR tells if the date is syntactically correct
C
	  	if(.not.datcor) goto 210
C
	  	if(lecrpt) then
	    	  ch3='no'
	    	  if(hasexp) ch3='yes'
	    	  call GPTOG('f',rptun,
     *        'Licence has expired = %t','\x','\x',ch3,' ',' ',
     *	      0,0,0.,0.,errmes)
            	  if( errmes(1:1).eq.'E') goto 15000
	  	end if
C
	      end if
C
C.end of bug fix [13/10/98]
C
	      goto 201
C
	  else if(relno.lt.5.995) then
C		Corrupted
	      goto 210
	  end if
C
	else
C
	  if(relno1.ge.5.195.and.relno1.le.5.205) then
	    if(relno2.gt.5.995) then
C
C	      Can ignore this line - it is a dummy "Rel 5.2" line inserted just
C	       to keep Rel 5.2 software happy.
C
	      relno=relno2
C
C		Delete the first of these 2 lines from 
C		  LIC() by moving the others down
C
	      do 73 i=linchk(5),nlic-1
	      lic(i)=lic(i+1)
73	      continue
C
	      nlic=nlic-1
C
	    else
C		Corrupted
	      goto 210
	    end if
	  else
C		Corrupted
	      goto 210
	  end if
	end if
C
	if(lecrpt) then
	  call GPTOG('f',rptun,
     *      'Licence release = %r','\x','\x',' ',' ',' ',
     *	    0,0,relno,0.,errmes)
          if( errmes(1:1).eq.'E') goto 15000
	end if
C
C [10/05/00] Convert from LCTPFL to LICTYP
C
	if(relno.lt.6.995) then
	  lictyp=lctpfl
	else
C
C		Rel 7.0 or later
C
	  if(lctpfl.eq.'L') then
C		Introductory licence
	    lictyp='I'
	  else
	    lictyp=lctpfl
	  end if
	end if
C
C [11/01/00] Here is place to trap for licence later than Rel 5.2
C	 which is not current
C
	if(relno.lt.6.995) goto 201	
C
C [03/04/98] Next replaced by above --------------------------------
C
C.rp        IF (LIC(LINCHK(5))(STCHK(5):ENDCHK(5)) .NE.
C.Rel5.2     * '          Licence for Release 5.2 of GEMPACK           ') then
C.rp     * '          Licence for Release 6.0 of GEMPACK           ') then
C
C.rp	  if(curlic) then
C
C.rp            IF (LIC(LINCHK(5))(STCHK(5):ENDCHK(5)) .eq.
C.rp     * '          Licence for Release 5.2 of GEMPACK           ') then
C	       Rel 5.2 licence
C.rp	      curlic=.FALSE.
C.rp	      goto 201
C.rp	    else
C		Corrupted
C.rp	      goto 210
C.rp	    end if
C
C.rp	  else
C
C.was	   Licence for Release 5.1 or earlier
C	   Licence for Release earlier than the current release
C
C.rp	    goto 201
C
C.rp	  end if
C
C.rp	end if
C
C [02/04/98] C.rp above replaced by earlier testing --------------------
C
C [12/02/96] Check Licence type
C [31/03/98] At this stage, CURLIC is true only for Rel 6.0 licences
C	  (see above where CURLIC is set false for Rel 5.2 licences)
C
C [02/04/98] For Rel 6.0/7.0, know the different possible LICTYP values
C	But cannot know this for future releases.
C	For future releases, report unknown licence type if it
C	 is not one of those used for Rel 6.0/7.0
C [08/05/00] For Rel 7.0 licences, Type 'L' means "Introductory licence"
C
C [10/05/00] Use LCTPFL instead of LICTYP
C
C.was	if(lictyp.ne.'s'.and.lictyp.ne.'e'.and.
C.was    *     lictyp.ne.'E'.and.lictyp.ne.'L') then
	if(lctpfl.ne.'s'.and.lctpfl.ne.'e'.and.
     *     lctpfl.ne.'E'.and.lctpfl.ne.'L') then
C
C	     Unknown licence type
C.R6	  if(relno.ge.5.995.and.relno.lt.6.005) then
	  if(relno.ge.5.995.and.relno.lt.7.005) then
C		Corrupted Rel 6.0/7.0 licence
	    goto 210
	  else
C	       Appears to be later release than current release
	    goto 204
	  end if
	end if
C
	if(curlic .and. .not.crnmsp) then
C
C.Rel5.2	  if(lictyp.eq.'e'.and.vtype.eq.'s') then
C [10/05/00] Use LCTPFL for the 'L' part of this
C.was	  if( (lictyp.ne.'s'.and.vtype.eq.'s').or.lictyp.eq.'L') then
	  if( (lictyp.ne.'s'.and.vtype.eq.'s').or.lctpfl.eq.'L') then
C.Rel5.2	       Is exe licence, require source-code licence
C [03/04/98] GPLCRQ() replaced by LICREQ
C.was	    if(gplcrq()) then
	    if(licreq) then
C              Licence type is lower than type required
	      goto 202
	    end if
	  end if
C
	end if
C
C [02/05/96] Check expiry date
C
	if(curlic.and.hasdat) then
C
C	  Last line has expiry date.
C
C	   Expiry date is on second last line between characters
C		STCHK(4) and ENDCHK(4)
C
	  tmplin=lic(nlic-1)
	  st=stchk(4)
	  en=endchk(4)
C
	  if(relno.ge.6.995) then
C
C [11/01/00] For Rel 7.0. Years now have 4 digits. 
C   Because line is centred, this means must subtract 1 from ST
C	and add 1 to EN.
C
	    st=st-1
	    en=en+1
C
	  end if
C
	  expdat=tmplin(st:en)
C
C	    Compare EXPDAT with DATE1 from first line of file
C
	  if(expdat.ne.date1) then
C
C	    The two expiry dates do not agree
C
	    goto 210
C
	  end if
C
C	  Check expiry date is ok. This also checks that EXPDAT is as expected
C
	  call GPCLED( expdat,
     *      datcor, hasexp, wrnexp, errmes)
          if( errmes(1:1).eq.'E') goto 15000
C
C.bug fix [13/10/98] Move DATCOR test here before write date to RPT file
C
C	  DATCOR tells if the date is syntactically correct
C
	  if(.not.datcor) goto 210
C
C.end of bug fix [13/10/98]
C
	  if(lecrpt) then
	    ch3='no'
	    if(hasexp) ch3='yes'
	    call GPTOG('f',rptun,
     *        'Licence has expired = %t','\x','\x',ch3,' ',' ',
     *	      0,0,0.,0.,errmes)
            if( errmes(1:1).eq.'E') goto 15000
	  end if
C
C.bug fix [13/10/98] Move DATCOR test earlier before write date to RPT file
C	  DATCOR tells if the date is syntactically correct
C
C.bug	  if(.not.datcor) goto 210
C
C.end of bug fix [13/10/98]
C
	  if(hasexp .and. .not.silent) then
C
C [03/04/98] GPLCRQ() replaced by LICREQ
C.was	    if(gplcrq()) then
	    if(licreq) then
C
C		Echo licence to screen
C
	      do 846 i=1,nlic
	      call GPTO1('%t',lic(i),0,errmes)
              if( errmes(1:1).eq.'E') goto 15000
846	      continue
C
	      call GPTO2(
     *         '\n \%\% Your GEMPACK licence expired on %s.',
     *         '\n You cannot run this program until you renew it.\n',
     *         expdat,' ',0,0,errmes)
              if( errmes(1:1).eq.'E') goto 15000
C
	      errmes='E-Licence has expired'
	      goto 15500
C
	    else
	      call GPTO1(
     *   '\n \%\%WARNING. Your GEMPACK licence expired on %s.\n',
     *         expdat,0,errmes)
              if( errmes(1:1).eq.'E') goto 15000
C
	      call GPWRN( 'in', 1)
	      errmes='W-Your GEMPACK licence expired on '//expdat
C
	      goto 9000
	    end if
C
	  end if
C
	  if(wrnexp .and. .not.silent) then
C
	   if(lictyp.eq.'L') then
	    call GPTO2(
     *        '\n \%\%WARNING. Your GEMPACK licence expires on %s.',
     * '\n You will not be able to run large TABLO-generated \n%s\n',
     *        expdat,
     * '   programs after that date unless you renew the licence.',
     *        0,0,errmes)
            if( errmes(1:1).eq.'E') goto 15000
C
C [10/05/00] New message for expired Intro licence
C
	   else if(lictyp.eq.'I') then
C
	    ch40='on '//expdat
	    call GPTOG('t', 0,
     * '\n \%\%WARNING. Your Introductory GEMPACK licence expires %t.',
     * '\n You will not be able to run large TABLO-generated \n%s\n%s',
     *        ch40,
     * '   programs, and may lose some functionality in ViewHAR etc',
     * '   after that date unless you renew the licence.',
     *        0,0,0.0,0.0,errmes)
            if( errmes(1:1).eq.'E') goto 15000
C
	   else
	    call GPTO2(
     *        '\n \%\%WARNING. Your GEMPACK licence expires on %s.',
     * '\n You will not be able to run GEMPACK programs \n%s\n',
     *        expdat,
     *        '   after that date unless you renew the licence.',
     *        0,0,errmes)
            if( errmes(1:1).eq.'E') goto 15000
	   end if
C
	    call GPWRN( 'in', 1)
	    errmes='W-Your GEMPACK licence will expire on '//expdat
C
	  end if
C
	end if
C
C       Formats for character READs and WRITEs
C       --------------------------------------
C
10005   FORMAT (A)
10110   FORMAT(I4)
C
C       Normal return
C       -------------
C
C.bug fix [08/05/99] For safety, move this to after 9000 so it catches all
C	 (non-fatal error) cases
C
C.v2        CLOSE(UNIT=CRYUN)
C.moved	  call CLSEQ( cryun, 'keep', errmes)
C.moved	  if(errmes(1:1).eq.'E') goto 15000
C
C.end of bug fix [08/05/99]
C
C	Release this unit number
C.bug fix [08/05/99] Must move this
C	 to after 9000 so that is catches returns when is no licence file
C
C.moved	  call GPUNIT( 'end', cryun, errmes)
C.moved	  if(errmes(1:1).eq.'E') goto 15000
C
C.end of bug fix [08/05/99]
C
C.was 2000	continue
9000	continue
C
C [31/03/98] Here 
C    (a) if NLIC=0, no uncorrupted Rel6.0 licence is available
C    (b) if NLIC>0, is an uncorrupted Rel6.0 licence of type LICTYP; then
C        (i) if GPLCRQ (ie TABLO or GEMSIM), it has not expired
C        (ii) otherwise, it has expired if both HASDAT and HASEXP are true,
C		in which case EXPDAT is the expiry date.
C    For GEMSIM need to store LICTYP for when check if is large model.
C    For TG-progs, need to store LICTYP and whether has expired for
C	  when check if is large model.
C
C?? Store LICTYP (or blank if NLIC=0), HASDAT.AND.HASEXP and EXPDAT in
C      GPRCON??
C
C.bug fix [08/05/99] For safety, move this here so it catches
C	  all cases. [And now only do it if CRYOP is true.]
C
	if(cryop) then
	  call CLSEQ( cryun, 'keep', errmes)
	  if(errmes(1:1).eq.'E') goto 15000
	  cryop=.FALSE.
	end if
C
C.end of bug fix [08/05/99]
C
C.bug fix [08/05/99] Release this unit number if CRYAS it true. 
C	And do it here so that is catches returns when is no licence file
C
	if(cryas) then
	  call GPUNIT( 'end', cryun, errmes)
	  if(errmes(1:1).eq.'E') goto 15000
	  cryas=.FALSE.
	end if
C
C.end of bug fix [08/05/99]
C
        RETURN
C
C       Read errors from LICEN.GEM
C       --------------------------
C
 200    CONTINUE
C
	if(lecrpt) then
	  call GPTOG('f',rptun,
     *      'Licence found = no','\x','\x',' ',' ',' ',
     *	    0,0,0.,0.,errmes)
          if( errmes(1:1).eq.'E') goto 15000
	end if
C
C [12/09/95] Addition to help diagnosis of licence problems
C
	call GPTO1('\n [Looking for licence file ''%t''.]',
     *    crynam(1:lcrynm), 0, errmes)
        IF(ERRMES(1:1).EQ.'E') GOTO 15000
C
CT        WRITE(*,10015) 'GEMPACK Licence Information unavailable.'
CT        WRITE(*,10015) 'This software cannot be accessed.'
CT        WRITE(*,10015) 'Consult your GEMPACK manager.'
        call GPTO2(
     *    '\nGEMPACK Licence Information unavailable.',
     *    '\nThis software cannot be accessed.\n%s',
     *    'Consult your GEMPACK manager.',' ',0,0,errmes)
	if(errmes(1:1).eq.'E') goto 15000
        ERRMES='E-Licence information unavailable.'
        GOTO 15500
C
C.was   Licence is for Release 5.1 or earlier
C	   Licence for Release earlier than the current release
C
 201    CONTINUE
C
	call CLSEQ( cryun, 'keep', errmes)
C.bug fix [08/05/99] Reset CRYOP
	cryop=.FALSE.
C.end of bug fix [08/05/99]
C
C [03/04/98] GPLCRQ() replaced by LICREQ
C.was	if(gplcrq()) then
	if(licreq) then
C
	  call GPTO1('\n [Using licence file ''%t''.]',
     *      crynam(1:lcrynm), 0, errmes)
          IF(ERRMES(1:1).EQ.'E') GOTO 15000
C
	  call GPTO2(
C.was     *      '\n This licence file is for Release 5.1 or %s.',
C.was     *      '\n You need the Release 5.2 licence for %s.',
C.R6     *      '\n This licence file is for Release 5.2 or %s.',
C.R6     *      '\n You need a Release 6.0 licence for %s.',
     *      '\n This licence file is for Release 6.0 or %s.',
     *      '\n You need a Release 7.0 licence for %s.',
     *      'earlier of GEMPACK','this software to run',
     *      0,0,errmes)
          if( errmes(1:1).eq.'E') goto 15000
C
	  if(.not.crnmsp) then
C.was	    errmes='E-Not Release 5.2 licence'
C.R6	    errmes='E-Not Release 6.0 licence'
	    errmes='E-Not Release 7.0 licence'
	    goto 15500
	  end if
C
	else
	  nlic=0
	  goto 9000
	end if
C
C   Below Licence is exe, require source-code
C
 202    CONTINUE
C
	call CLSEQ( cryun, 'keep', errmes)
C.bug fix [08/05/99] Reset CRYOP
	cryop=.FALSE.
C.end of bug fix [08/05/99]
C
C [03/04/98] GPLCRQ() replaced by LICREQ
C.was	if(gplcrq()) then
	if(licreq) then
C
	  call GPTO1('\n [Using licence file ''%t''.]',
     *      crynam(1:lcrynm), 0, errmes)
          IF(ERRMES(1:1).EQ.'E') GOTO 15000
C
C [10/05/00] Add 'I'
C
C.was	  if(lictyp.eq.'L') then
	  if(lictyp.eq.'L'.or.lictyp.eq.'I') then
C
	    if(lictyp.eq.'L') then
	      call GPTO1(
     *          '\n This licence file is a "Large Simulations"%s.',
     *          ' GEMPACK licence',0,errmes)
              if( errmes(1:1).eq.'E') goto 15000
	    else if(lictyp.eq.'I') then
	      call GPTO1(
     *          '\n This licence file is an Introductory%s.',
     *          ' GEMPACK licence',0,errmes)
              if( errmes(1:1).eq.'E') goto 15000
	    end if
C
	    if(vtype.eq.'e') then
	      call GPTO1(
     *          ' You need an Executable-image %s.',
     *          'licence for this software to run',0,errmes)
              if( errmes(1:1).eq.'E') goto 15000
	    else if(vtype.eq.'s') then
	      call GPTO1(
     *          ' You need a Source-code %s.',
     *          'licence for this software to run',0,errmes)
              if( errmes(1:1).eq.'E') goto 15000
	    end if
C
	  else
C		Here LICTYP is either 'e' or 'E'
	    call GPTO2(
     *        '\n This licence file is for an Executable-image%s.',
     *        '\n You need a Source-code licence for %s.',
     *        ' version of GEMPACK','this software to run',
     *        0,0,errmes)
            if( errmes(1:1).eq.'E') goto 15000
C
	  end if
C
C.Rel5.2	  errmes='E-Need source-code licence'
	  errmes='E-Need different licence'
	  goto 15500
C
	else
	  nlic=0
	  goto 9000
	end if
C
C [02/04/98]  Licence for Release later than the current release
C	  but of a type not used in the current release
C
 204    CONTINUE
C
	call CLSEQ( cryun, 'keep', errmes)
C.bug fix [08/05/99] Reset CRYOP
	cryop=.FALSE.
C.end of bug fix [08/05/99]
C
C [03/04/98] GPLCRQ() replaced by LICREQ
C.was	if(gplcrq()) then
	if(licreq) then
C
	  call GPTO1('\n [Using licence file ''%t''.]',
     *      crynam(1:lcrynm), 0, errmes)
          IF(ERRMES(1:1).EQ.'E') GOTO 15000
C
	  call GPTO2(
     * '\n This licence file appears to be for a later \n%s.',
C.R6     * '\n It is of a type unknown to Release 6.0 software.\n%s',
C.R6     *      '  release than Release 6.0 of GEMPACK',
C.R6     * ' You need a Release 6.0 licence for this software to run.',
     * '\n It is of a type unknown to Release 7.0 software.\n%s',
     *      '  release than Release 7.0 of GEMPACK',
     * ' You need a Release 7.0 licence for this software to run.',
     *      0,0,errmes)
          if( errmes(1:1).eq.'E') goto 15000
C
	  if(.not.crnmsp) then
C.was	    errmes='E-Not Release 5.2 licence'
C.R6	    errmes='E-Licence type unknown to Release 6.0 software'
	    errmes='E-Licence type unknown to Release 7.0 software'
	    goto 15500
	  end if
C
	else
	  nlic=0
	  goto 9000
	end if


C
 210    CONTINUE
C
	call CLSEQ( cryun, 'keep', errmes)
C.bug fix [08/05/99] Reset CRYOP
	cryop=.FALSE.
C.end of bug fix [08/05/99]
C
	if(lecrpt) then
	  call GPTOG('f',rptun,
     *      'Licence currupted = yes','\x','\x',' ',' ',' ',
     *	    0,0,0.,0.,errmes)
          if( errmes(1:1).eq.'E') goto 15000
	end if
C
C [03/04/98] GPLCRQ() replaced by LICREQ
C.was	if(gplcrq()) then
	if(licreq) then
C
C [12/09/95] Addition to help diagnosis of licence problems
C
	  call GPTO1('\n [Using licence file ''%t''.]',
     *      crynam(1:lcrynm), 0, errmes)
          IF(ERRMES(1:1).EQ.'E') GOTO 15000
C
CT        WRITE(*,10015) 'GEMPACK Licence Information corrupted.'
CT        WRITE(*,10015) 'This software cannot be accessed.'
CT        WRITE(*,10015) 'Consult your GEMPACK manager.'
          call GPTO2(
     *      '\nGEMPACK Licence Information corrupted.',
     *      '\nThis software cannot be accessed.\n%s',
     *      'Consult your GEMPACK manager.',' ',0,0,errmes)
	  if(errmes(1:1).eq.'E') goto 15000
C
	  if(.not.crnmsp) then
            ERRMES='E-Licence information corrupted.'
            GOTO 15500
	  end if
C
	else
	  nlic=0
	  goto 9000
	end if
C
C       Error RETURN for orderly stop
C       -----------------------------
C
15000   CONTINUE
        CALL PERET (SUBNAM)
        RETURN
C
C   (Program error)
C
15300	CONTINUE
	CALL GPPGER( 0, ERRMES)
	GOTO 15500
C
C
15500   CONTINUE
        CALL PERETM (SUBNAM, ERRMES)
        RETURN
C
        END
C   GEMPACK Software System                         Impact Project
C   -----------------------                         --------------
C
        SUBROUTINE FDRLNO( 
     *    line, fndrel, relno,
     *    ERRMES)
C
C   ACRONYM
C   -------
C
C    FinD ReLease Number
C    F  D R L     NO
C
C   DESCRIPTION
C   -----------
C

C
C   CURRENT VERSION
C   ---------------
C
C       Version 1               April 1998 
C
C   HISTORY
C   -------
C
C   Date           Author(s)            Comments
C   --------------------------------------------------------------
C   03/04/98       Ken Pearson         Version 1 - extracted from GPLIC0
C
C   NOTES
C   -----
C
C       - All variables used are declared explicitly.
C
C   SUBROUTINE VARIABLES
C   --------------------
C
C   (1) INPUT VARIABLES (NOT ALTERED):
C
C	LINE - the line being tested
C
	character*(*) line
C
C   (2) OUTPUT VARIABLES (RETURNED):
C
C	FNDREL - if found Release number
C	RELNO - the number found
C
	logical fndrel
	real relno
C
C   (3) INPUT/OUTPUT VARIABLES:
C
C       ERRMES - Contains fatal error messages if ERRMES(1:1)='E'
C
        CHARACTER*(*)   ERRMES
C
C   SIGNIFICANT PARAMETERS
C   ----------------------
C
C       SUBNAM - The name of this subroutine
C
        CHARACTER*6     SUBNAM
        PARAMETER       (SUBNAM='FDRLNO')
C
C       LLCRNM - maximum length of licence file name
C
        INTEGER         LLCRNM
        PARAMETER       (LLCRNM=100)
C
C
C   ERROR CHECKING AND HANDLING
C   ---------------------------
C
C       A fatal error (ERRMES(1:1)='E') results if:
C

C
C   LOCAL VARIABLES
C   ---------------
C
	character*80 str1, str2
C  Next are STCHK(5),ENDCHK(5) in GPLIC0
	integer stchk, endchk
	parameter(stchk=5,endchk=59)
	integer last, i
	logical isreal
C
C   SUBROUTINES AND FUNCTIONS CALLED
C   --------------------------------
C
        EXTERNAL PERET, gppger, PERETM
	intrinsic LEN
C
C       **********************************************************
C
C       End of subroutine documentation
C
C       **********************************************************
C
C   IMPORTANT STATEMENT LABELS
C   --------------------------
C
C       15000   15500           Error return for orderly stop
C
C       **********************************************************
C
C       Subroutine begins
C
C       **********************************************************
C
	fndrel=.FALSE.
C
C.GPLIC0	str2=str1(stchk(5):endchk(5))
C.GPLIC0	str2=str1(stchk(5):endchk(5))
	str1=line
	str2=str1(stchk:endchk)
C
	if(str2(1:30).ne.'          Licence for Release ') then
	  goto 9000
	end if
C
C	Below can be sure line is from Release 5.2 or later
C
C	Here Release number should follow
C
	str1=str2(31:)
C
C	Here try to accept licences for Releases later than 6.0
C
C	Find first space
C
	do 46 i=1,LEN(str1)
	if(str1(i:i).eq.' ') then
	  last=i-1
	  goto 48
	end if
46	continue
	last=LEN(str1)
48	continue
C
	if(last.eq.1) then
C		Corrupted
	    goto 9000
	end if
C
	call GPCHTR(str1(1:last), isreal, relno, errmes)
        if( errmes(1:1).eq.'E') goto 15000
C
	if(.not.isreal) then
C		Corrupted
	    goto 9000
	end if
C
	fndrel=.TRUE.

C
C	Normal return
C	-------------
C
9000	continue
	RETURN
C
C	Error RETURN for orderly stop
C	-----------------------------
C
15000	CONTINUE
	CALL PERET (SUBNAM)
	RETURN
C
C   (Program error)
C
15300	CONTINUE
	CALL GPPGER( 0, ERRMES)
	GOTO 15500
C
15500	CONTINUE
	CALL PERETM (SUBNAM, ERRMES)
	RETURN
C
	END

C   GEMPACK Software System                         Impact Project
C   -----------------------                         --------------
C
        SUBROUTINE GPLIC2( 
     *    lictyp, hasexp, expdat, silent,
     *    ERRMES)
C
C   ACRONYM
C   -------
C
C       GemPack LICence information - version 2
C       G  P    LIC			      2
C
C   DESCRIPTION
C   -----------
C
C       This enables GEMPACK licence information to be available
C       to other GEMPACK routines.
C
C   CURRENT VERSION
C   ---------------
C
C       Version 1               April 1998
C
C   HISTORY
C   -------
C
C   Date           Author(s)            Comments
C   --------------------------------------------------------------
C   31 March 1998  Ken Pearson         V 1 for Release 6.0
C
C   NOTES
C   -----
C
C       - All variables used are declared explicitly.
C
C   SUBROUTINE VARIABLES
C   --------------------
C
C   (1) INPUT VARIABLES (NOT ALTERED):
C
C	SILENT - whether this is to be silent or not for warnings etc
C		[The routine is never silent if get fatal error]
C
	logical silent
C
C   (2) OUTPUT VARIABLES (RETURNED):
C
C	LICTYP - licence type: ' '=none, 'L'=Large Sims,
C		   'e'=Limited Exe, 'E'=Unlimited Exe,'s'=Source-code
C	HASEXP - if licence has expired
C	EXPDAT - expiry date
C
	character*(*) lictyp
	logical hasexp
	character*(*) expdat
C
C   (3) INPUT/OUTPUT VARIABLES:
C
C       ERRMES - Contains fatal error messages if ERRMES(1:1)='E'
C
        CHARACTER*(*)   ERRMES
C
C   SIGNIFICANT PARAMETERS
C   ----------------------
C
C       SUBNAM - The name of this subroutine
C
        CHARACTER*6     SUBNAM
        PARAMETER       (SUBNAM='GPLIC2')
C
C
C   ERROR CHECKING AND HANDLING
C   ---------------------------
C
C       A fatal error (ERRMES(1:1)='E') results if:
C
C
C   LOCAL VARIABLES
C   ---------------
C
C	For call to GPLIC0
C
	integer ddlic, nlic
	parameter(ddlic=20)
	character*70 lic(ddlic)

C       **********************************************************
C
C       End of subroutine documentation
C
C       **********************************************************
C
C   IMPORTANT STATEMENT LABELS
C   --------------------------
C
C       15000   15500           Error return for orderly stop
C
C       **********************************************************
C
C       Subroutine begins
C
C       **********************************************************
C
        call GPLIC0( DDLIC, NLIC, LIC,
     *    lictyp, hasexp, expdat, silent,
C CRNMSP is false, next are dummies
C.usual   CRNMSP, SCRYUN, SCRYNM, ECHRPT,
     *    .FALSE., 0, ' ', .FALSE.,
     *    ERRMES)
        if( errmes(1:1).eq.'E') goto 15000
C
C       Normal return
C       -------------
C
        RETURN
C
C       Error RETURN for orderly stop
C       -----------------------------
C
15000   CONTINUE
        CALL PERET (SUBNAM)
        RETURN
C
C   (Program error)
C
C15300	CONTINUE
C	CALL GPPGER( 0, ERRMES)
C	GOTO 15500
C
C
C15500   CONTINUE
C        CALL PERETM (SUBNAM, ERRMES)
C        RETURN
C
        END
C	GEMPACK Software System			    Impact Project
C	-----------------------			    --------------
C
C [02/04/98] Omit ERRMES
C.was	SUBROUTINE GPPRN( prname,
C.was     *    ERRMES)
	SUBROUTINE GPPRN( prname)
C
C   ACRONYM
C   -------
C
C GemPack: find PRogram Name
C G  P          PR      N
C
C	COPYRIGHT 1996: The Impact Project and KPSOFT
C
C   DESCRIPTION
C   -----------
C
 
C
C   CURRENT VERSION
C   ---------------
C
C	Version 1.1		April 1998
C
C   HISTORY
C   -------
C
C   Date           Author(s)            Comments
C   --------------------------------------------------------------
C   02/04/98       Ken Pearson		V 1.1 - omit ERRMES
C   03/05/96       Ken Pearson		Version 1
C
C   NOTES
C   -----
C
C PRNAME is stored in GPRCON by GPSPRN
C
C   FINE PRINT
C   ----------
C
C	- All variables and arrays are explicitly declared. None
C	  are implicit.
C
C   SUBROUTINE VARIABLES
C   --------------------
C
C   (1) INPUT VARIABLES (NOT ALTERED):
C
 
C
C   (2) OUTPUT VARIABLES (RETURNED):
C
	character*(*) prname
 
C
C   (3) INPUT/OUTPUT VARIABLES:
C
C.old	ERRMES - Contains fatal error messages if ERRMES(1:1)='E'
C
C.old	CHARACTER*(*) 	ERRMES
C
C   SIGNIFICANT PARAMETERS
C   ----------------------
C
C	SUBNAM - The name of this subroutine
C
	CHARACTER*6 	SUBNAM
	PARAMETER   	(SUBNAM='GPPRN')
C
C   COMMON BLOCK TO CONTROL RUN CHARACTERISTICS
C   -------------------------------------------
C
C
C  GPRCON,GPRCNI stored as common blocks to control various run-time
C	   features such as recovery from invalid input, full/brief prompts,
C          whether running from Stored-input/Command file etc.
C
	character*128 gprcon
	common /gprun/ gprcon
C
C   ERROR CHECKING AND HANDLING
C   ---------------------------
C
C	A fatal error (ERRMES(1:1)='E') results if:
 
C
C   SUBROUTINES AND FUNCTIONS CALLED
C   --------------------------------
C
C	EXTERNAL GPPGER, PERET, PERETM
	INTRINSIC LEN, MAX
C
C	**********************************************************
C
C	End of subroutine documentation
C
C	**********************************************************
C
C   LOCAL VARIABLES
C   ---------------
C
	integer n1, i
C
C
C	**********************************************************
C
C	Subroutine begins
C
C	**********************************************************
C
	prname=' '
C
	n1=LEN(prname)
C
	do 20 i=1,MAX(n1,8)
	prname(i:i)=gprcon(30+i:30+i)
20	continue
C
C	Normal return
C	-------------
C
	RETURN
C
C
C	Error RETURN for orderly stop
C	-----------------------------
C
C15000	CONTINUE
C	CALL PERET (SUBNAM)
C	RETURN
C
C   (Program error)
C
C15300	CONTINUE
C	CALL GPPGER( 0, ERRMES)
C	GOTO 15500
C
C15500	CONTINUE
C	CALL PERETM (SUBNAM, ERRMES)
C	RETURN
C
	END
C	GEMPACK Software System			    Impact Project
C	-----------------------			    --------------
C
	SUBROUTINE GPSPRN( prname,
     *    ERRMES)
C
C   ACRONYM
C   -------
C
C GemPack: Set PRogram Name
C G  P     S   PR      N
C
C	COPYRIGHT 1996: The Impact Project and KPSOFT
C
C   DESCRIPTION
C   -----------
C
 
C
C   CURRENT VERSION
C   ---------------
C
C	Version 1		May 1996
C
C   HISTORY
C   -------
C
C   Date           Author(s)            Comments
C   --------------------------------------------------------------
C   03/05/96       Ken Pearson		Version 1
C
C   NOTES
C   -----
C
 
C
C   FINE PRINT
C   ----------
C
C	- All variables and arrays are explicitly declared. None
C	  are implicit.
C
C   SUBROUTINE VARIABLES
C   --------------------
C
C   (1) INPUT VARIABLES (NOT ALTERED):
C
	character*(*) prname
C
C   (2) OUTPUT VARIABLES (RETURNED):
C
 
C
C   (3) INPUT/OUTPUT VARIABLES:
C
C	ERRMES - Contains fatal error messages if ERRMES(1:1)='E'
C
	CHARACTER*(*) 	ERRMES
C
C   SIGNIFICANT PARAMETERS
C   ----------------------
C
C	SUBNAM - The name of this subroutine
C
	CHARACTER*6 	SUBNAM
	PARAMETER   	(SUBNAM='GPSPRN')
C
C   COMMON BLOCK TO CONTROL RUN CHARACTERISTICS
C   -------------------------------------------
C
C
C  GPRCON,GPRCNI stored as common blocks to control various run-time
C	   features such as recovery from invalid input, full/brief prompts,
C          whether running from Stored-input/Command file etc.
C
	character*128 gprcon
	common /gprun/ gprcon
C
C   ERROR CHECKING AND HANDLING
C   ---------------------------
C
C	A fatal error (ERRMES(1:1)='E') results if:
 
C
C   SUBROUTINES AND FUNCTIONS CALLED
C   --------------------------------
C
	EXTERNAL GPPGER, PERET, PERETM
	external tbtrcs
	INTRINSIC LEN, MAX
C
C	**********************************************************
C
C	End of subroutine documentation
C
C	**********************************************************
C
C   LOCAL VARIABLES
C   ---------------
C
	integer i
	character*8 xname
C
C
C	**********************************************************
C
C	Subroutine begins
C
C	**********************************************************
C
C	Copy PRNAME to XNAME (this will truncate or pad out with blanks)
C
	xname=prname
C
C	Translate XNAME to upper case
C
	call TBTRCS( xname, 'UPPER', errmes)
        if( errmes(1:1).eq.'E') goto 15000
C
	do 20 i=1,8
	gprcon(30+i:30+i)=xname(i:i)
20	continue
C
C	Normal return
C	-------------
C
	RETURN
C
C
C	Error RETURN for orderly stop
C	-----------------------------
C
15000	CONTINUE
	CALL PERET (SUBNAM)
	RETURN
C
C   (Program error)
C
C15300	CONTINUE
C	CALL GPPGER( 0, ERRMES)
C	GOTO 15500
C
C15500	CONTINUE
C	CALL PERETM (SUBNAM, ERRMES)
C	RETURN
C
	END
C	GEMPACK Software System			    Impact Project
C	-----------------------			    --------------
C
	LOGICAL FUNCTION GPTGP( )
C
C   ACRONYM
C   -------
C
C GemPack: is this a Tablo-Generated Program ?
C G  P               T     G         P
C
C	COPYRIGHT 1998: The Impact Project and KPSOFT
C
C   DESCRIPTION
C   -----------
C

C
C   CURRENT VERSION
C   ---------------
C
C	Version 1		April 1998
C
C   HISTORY
C   -------
C
C   Date           Author(s)            Comments
C   --------------------------------------------------------------
C   01/04/98       Ken Pearson		Version 1 
C
C   NOTES
C   -----
C

C
C   FINE PRINT
C   ----------
C
C	- All variables and arrays are explicitly declared. None
C	  are implicit.
C
C   SUBROUTINE VARIABLES
C   --------------------
C
C   (1) INPUT VARIABLES (NOT ALTERED):
C

C
C   (2) OUTPUT VARIABLES (RETURNED):
C

C
C   (3) INPUT/OUTPUT VARIABLES:
C
C	ERRMES - Contains fatal error messages if ERRMES(1:1)='E'
C
C	CHARACTER*(*) 	ERRMES
C
C   SIGNIFICANT PARAMETERS
C   ----------------------
C
C	SUBNAM - The name of this subroutine
C
	CHARACTER*6 	SUBNAM
	PARAMETER   	(SUBNAM='GPTGP')
C
C   COMMON BLOCK TO CONTROL RUN CHARACTERISTICS
C   -------------------------------------------
C
C
C  GPRCON,GPRCNI stored as common blocks to control various run-time
C	   features such as recovery from invalid input, full/brief prompts,
C          whether running from Stored-input/Command file etc.
C
	character*128 gprcon
	common /gprun/ gprcon
C
C   ERROR CHECKING AND HANDLING
C   ---------------------------
C
C	A fatal error (ERRMES(1:1)='E') results if:

C
C   SUBROUTINES AND FUNCTIONS CALLED
C   --------------------------------
C
C	EXTERNAL GPPGER, PERET, PERETM
C
C	**********************************************************
C
C	End of subroutine documentation 
C
C	**********************************************************
C
C   LOCAL VARIABLES
C   ---------------
C
	character*8 name
C
C
C	**********************************************************
C
C	Subroutine begins
C
C	**********************************************************
C
C Use GPPRN [no ERRMES in its call]
C
	call GPPRN(name)
C
	if(name.eq.'TGPROG') then
	  gptgp=.TRUE.
	else
	  gptgp=.FALSE.
	end if
C
C	Normal return
C	-------------
C
	RETURN
C
C
C	Error RETURN for orderly stop
C	-----------------------------
C
C15000	CONTINUE
C	CALL PERET (SUBNAM)
C	RETURN
C
C   (Program error)
C
C15300	CONTINUE
C	CALL GPPGER( 0, ERRMES)
C	GOTO 15500
C
C15500	CONTINUE
C	CALL PERETM (SUBNAM, ERRMES)
C	RETURN
C
	END
